1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;; -*-LISP-*-
 11 
 12 ;;;
 13 ;;;       Tektronix 4025 control package
 14 ;;;       Snarfed from VIP7800 package,
 15 ;;;       In turn ripped off from VIP7200ctl
 16 ;;;
 17 ;;;       Roy A. Leban, January 15, 1979.
 18 ;;;
 19 ;;;    Notes on current problems with this implementation:
 20 ;;;    1) It is possible to have screens > 33 lines.  This is not done.
 21 ;;;    2) User setable command character desirable.
 22 
 23 (declare (special X Y screenheight screenlinelen tty-type))
 24 (declare (special idel-lines-availablep idel-chars-availablep))
 25 (declare (special ctl-close-necessaryp))
 26 
 27 ; Initialize terminal and terminal control package.
 28 (defun DCTL-init ()
 29        (setq idel-lines-availablep t idel-chars-availablep t)
 30        (setq screenheight 33. screenlinelen 79.)
 31        (setq tty-type 'tek4025)(setq ctl-close-necessaryp t)
 32        (Rtyo 37)(Rprinc "wor 33")(Rtyo 15) ;Work space of 33 lines
 33        (Rtyo 37)(Rprinc "wor")(Rtyo 15)     ;Go to top of work space.
 34        (setq X 0 Y 33))
 35 
 36 
 37 ; Move terminal's cursor to desired position.
 38 (defun DCTL-position-cursor (x y)
 39        (cond ((and (= x X)(= y Y))
 40               nil)
 41              ((and (= x 0)(= y 0))
 42               (Rtyo 37)(Rprinc "jum")(Rtyo 15)
 43               (setq X 0 Y 0))
 44              ((= x 0)                 ; column 1 of a line.
 45               (Rtyo 37)(Rprinc "jum ")
 46               (DCTL-4025-outnum (+ y 1))
 47               (Rtyo 15)
 48               (setq X x Y y))
 49              ((and (= x X)(> Y y))    ; same column- up.
 50               (Rtyo 37)(Rprinc "up ")
 51               (DCTL-4025-outnum (- Y y))
 52               (Rtyo 15)
 53               (setq Y y))
 54              ((and (= x X)(< Y y))       ; same column- down.
 55               (Rtyo 37)(Rprinc "dow ")
 56               (DCTL-4025-outnum (- y Y))
 57               (Rtyo 15)
 58               (setq Y y))
 59              ((and (= y Y)(> X x))       ; same line- left.
 60               (Rtyo 37)(Rprinc "lef ")
 61               (DCTL-4025-outnum (- X x))
 62               (Rtyo 15)
 63               (setq X x))
 64              ((and (= y Y)(< X x))       ; same line- right.
 65               (Rtyo 37)(Rprinc "rig ")
 66               (DCTL-4025-outnum (- x X))
 67               (Rtyo 15)
 68               (setq X x))
 69 ;;else do a jump with both line and column.
 70              (t (setq X x Y y)
 71               (Rtyo 37)(Rprinc "jum ")
 72               (DCTL-4025-outnum (+ y 1))
 73               (Rprinc ",")
 74               (DCTL-4025-outnum (+ x 1))
 75               (Rtyo 15))))
 76 
 77 ; Output string.
 78 (defun DCTL-display-char-string (string)
 79        (setq X (+ X (stringlength string)))
 80        (Rprinc string))
 81 
 82 
 83 ; Clear to end of screen.
 84 (defun DCTL-clear-rest-of-screen ()
 85        (Rtyo 37)(Rprinc "dli 33")   ; max of 33 lines left in buffer.
 86        (Rtyo 15))
 87 
 88 
 89 ; Clear to end of line.
 90 (defun DCTL-kill-line ()
 91        (Rtyo 37)(Rprinc "dch 80")   ; max of 80 chars left in line.
 92        (Rtyo 15))
 93 
 94 
 95 (defun DCTL-insert-lines (n)
 96        (Rtyo 37)(Rprinc "ili ")   ; Note the inherent problem with this.
 97        (DCTL-4025-outnum n)       ; ili causes lines at the bottom to
 98        (Rtyo 15))                 ; roll of the screen but not out of
 99                                   ; the terminal.
100 
101 (defun DCTL-delete-lines (n)
102        (Rtyo 37)(Rprinc "dli ")         ; first delete the lines,
103        (DCTL-4025-outnum n)
104        (Rtyo 15)
105        (DCTL-insert-lines n))           ; then rejustify with inserts.
106 
107 
108 (defun DCTL-insert-char-string (str)
109        (Rtyo 37)(Rprinc "ich")(Rtyo 15)
110        (Rprinc str)
111                ; should automatically revert out. if not "!wor"
112        (setq X (+ X (stringlength str))))
113 
114 
115 (defun DCTL-delete-chars (n)
116        (Rtyo 37)(Rprinc "dch ")
117        (DCTL-4025-outnum n)
118        (Rtyo 15))
119 
120 (defun DCTL-4025-outnum (n)
121        (cond ((> n 9.)
122            (Rtyo (+ 60 (// n 10.)))
123            (setq n (- n (* 10. (// n 10.))))))
124        (Rtyo (+ 60 n)))
125 
126 (defun DCTL-close-screen ()
127        (Rtyo 37)(Rprinc "wor 0")(Rtyo 15))