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 ;;;       Delta Data 4000 control package
 14 ;;;       BSG 3/78
 15 ;;;       Modified by EAK 3/18/78
 16 ;;;       Consing removed in recognition of output buffering, BSG 8/31/78
 17 
 18 (declare (special xconses yconses DCTLV-escf X Y screenheight ospeed screenlinelen tty-eolch-lossp))
 19 (declare (special idel-lines-availablep idel-chars-availablep tty-type))
 20 
 21 ;;;
 22 ;;;       Whoever invented the **** eol frobs that caused me to have to
 23 ;;;       propagate tty-eolch-lossp throughout n levels of hair,
 24 ;;;       him, his fingers should be cut off.
 25 
 26 ; Initialize terminal and terminal control package.
 27 (defun DCTL-init ()
 28 ;      (setq idel-lines-availablep (= ospeed 1200.))
 29 ;      (setq idel-chars-availablep (< ospeed 1200.))
 30        (setq idel-lines-availablep t idel-chars-availablep nil)
 31                               ; This seems to be the most popular menu of poisons.
 32        (setq tty-eolch-lossp idel-lines-availablep)
 33        (setq DCTLV-escf (catenate (ascii 33) 'F))
 34        (setq screenheight 25. screenlinelen 79.)
 35        (setq tty-type 'dd4000)
 36        (Rtyo 33) (Rprinc "E")
 37        (setq X 0 Y 0))
 38 
 39 
 40 ; Move terminal's cursor to desired position.
 41 (defun DCTL-position-cursor (x y)
 42        (cond ((and (= x X)(= y Y))
 43               nil)
 44              ((and (= x 0)(= y 0))
 45               (Rtyo 33)(Rprinc "H")
 46               (setq X 0 Y 0))
 47              ((and (< (+ (abs (- X x))(abs (- Y y))) 4))
 48               (cond ((< X x)
 49                      (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C")(DCTL-pad 2500.)))
 50                     ((< x X)
 51                      (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "D")(DCTL-pad 2500.))))
 52               (cond ((< Y y)
 53                      (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B")(DCTL-pad 2500.)))
 54                     ((< y Y)
 55                      (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")(DCTL-pad 2500.))))
 56               (setq X x Y y))
 57 ;; Direct Cursor Addressing is best.
 58              (t (setq X x Y y)
 59                 (DCTL-pad 3000.)
 60                 (Rprinc DCTLV-escf)
 61                 (Rtyo (+ 60 (// x 100.)))(setq x (\ x 100.))
 62                 (Rtyo (+ 60 (// x 10.)))(setq x (\ x 10.))
 63                 (Rtyo (+ 60 x))
 64 
 65                 (Rtyo (+ 60 (// y 100.)))(setq y (\ y 100.))
 66                 (Rtyo (+ 60 (// y 10.)))(setq y (\ y 10.))
 67                 (Rtyo (+ 60 y))
 68 
 69                 (DCTL-pad 5000.)
 70                     )))
 71 
 72 
 73 ; Output string.
 74 (defun DCTL-display-char-string (string)
 75        (setq X (+ X (stringlength string)))
 76        (Rprinc string))
 77 
 78 
 79 ; Clear to end of screen.
 80 (defun DCTL-clear-rest-of-screen ()
 81        (DCTL-pad 9000.)
 82        (Rtyo 33)(Rprinc "J")(DCTL-pad 15000.))
 83 
 84 
 85 ; Clear to end of line.
 86 (defun DCTL-kill-line ()
 87        (DCTL-pad 10000.)
 88        (Rtyo 33)(Rprinc "K")
 89        (DCTL-pad 7500.))
 90 
 91 
 92 ; Insert character string in line at current position.
 93 (defun DCTL-insert-char-string (str)
 94        (Rtyo 33)(Rprinc "Q")
 95        (Rprinc str)
 96        (Rtyo 33)(Rprinc "R")
 97        (setq X (+ X (stringlength str))))
 98 
 99 
100 ; Delete characters from current position in line.
101 (defun DCTL-delete-chars (n)
102        (do i 1 (1+ i)(> i n)
103            (Rtyo 33)(Rprinc "P")(DCTL-pad 2500.)))
104 
105 
106 ; Insert n blank lines at current position.
107 (defun DCTL-insert-lines (n)
108        (do i 1 (1+ i)(> i n)
109            (Rtyo 33)(Rprinc "L")(DCTL-pad 2500.)))
110 
111 
112 ; Delete n lines at current position.
113 (defun DCTL-delete-lines (n)
114        (do i 1 (1+ i)(> i n)
115            (Rtyo 33)(Rprinc "M")(DCTL-pad 100000.)))
116 
117 
118 ; Send pad characters to wait specified no. of microseconds.
119 (defun DCTL-pad (n)
120        (do i (// (* n ospeed) 1000000.) (1- i) (= i 0)
121            (Rtyo 0)))
122 
123 ; Random underscore to turn off losing DD features at high speeds.
124 
125 (defun idel-off ()
126        (setq idel-lines-availablep nil idel-chars-availablep nil))