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 ;;;       Micromind Ctl
 14 ;;;       From DD4000 5/18/78 BSG
 15 ;;;       Modified 3/23/79 JSL
 16 ;;;
 17 
 18 (declare (special X Y screenheight screenlinelen ospeed rdis-whitespace-optimize))
 19 (declare (special idel-lines-availablep idel-chars-availablep tty-type overstrike-availablep))
 20 (declare (defpl1 e_pl1_$get_mcs_tty_info "" (return bit (1))(return float bin)(return fixed bin)
 21           (return float bin)(return fixed bin)(return fixed bin)(return fixed bin)))
 22 
 23 ; Initialize terminal and terminal control package.
 24 
 25 (defun DCTL-init ()
 26        (setq idel-lines-availablep t idel-chars-availablep t overstrike-availablep t)
 27        (setq rdis-whitespace-optimize nil)
 28        (setq tty-type 'micromind)
 29        (setq screenlinelen (1- (caddr (cddddr (e_pl1_$get_mcs_tty_info)))) screenheight 34.)
 30        (setq X -777 Y -777)   ; N.B. ^L does this so we should be able to handle it.
 31        (DCTL-position-cursor 0 0)
 32        (DCTL-clear-rest-of-screen))
 33 
 34 ; Move terminal's cursor to desired position.
 35 
 36 (defun DCTL-position-cursor (x y)
 37        (cond ((and (= x X)(= y Y)) nil)           ; we're there...do nothing
 38              ((and (= x 0)(= y Y))(Rtyo 15))      ; just go to beginning of current line
 39              ((and (= x 0)(= y 0))(Rtyo 33)(Rprinc "H")(DCTL-pad (* 25000. (min (abs Y) screenheight)))) ; go home.
 40              ((and (< (+ (max (min (- X x)(1+ (* 2 x)))(* 2 (- x X)))(max (- y Y)(* 2 (- Y y)))) (cond ((< X 95.) 4)(t 8))))
 41               (and (< (1+ (* 2 x)) (- X x)) (setq X 0) (Rtyo 15))     ; yes. do carriage return if faster.
 42               (cond ((< X x)
 43                      (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C")))  ; move right
 44                     ((< x X)
 45                      (do ex x (1+ ex)(= ex X)(Rtyo 10))))   ; move left
 46               (cond ((< Y y)
 47                      (do wy Y (1+ wy)(= wy y)(Rtyo 12)(DCTL-pad 25000.)))  ; move down
 48                     ((< y Y)
 49                      (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")(DCTL-pad 25000.)))))   ; move up
 50              ((< x 95.)(Rtyo 33)(Rprinc "Y")      ; use abs. cursor address. short form?
 51                        (Rtyo (+ y 41))
 52                        (Rtyo (+ x 40))
 53                        (DCTL-pad (* 25000. (min (abs (- y Y)) screenheight))))
 54              (t (Rtyo 33) (Rprinc "F")            ; no. use long form.
 55                 (Rtyo (+ 60 (// x 100.)))
 56                 (Rtyo (+ 60 (\ (// x 10.) 10.)))
 57                 (Rtyo (+ 60 (\ x 10.)))
 58                 (Rtyo (+ 60 (// y 100.)))
 59                 (Rtyo (+ 60 (\ (// y 10.) 10.)))
 60                 (Rtyo (+ 60 (\ y 10.)))
 61                 (DCTL-pad (* 25000. (min (abs (- y Y)) screenheight)))))
 62        (setq X x Y y))
 63 
 64 ; Output string.
 65 
 66 (defun DCTL-display-char-string (string)
 67        (setq X (+ X (stringlength string)))
 68        (Rprinc string))
 69 
 70 ; Clear to end of screen.
 71 
 72 (defun DCTL-clear-rest-of-screen ()
 73        (Rtyo 33)(Rprinc "J")
 74        (DCTL-pad (* 50000. (- screenheight Y))))
 75 
 76 ; Clear to end of line.
 77 
 78 (defun DCTL-kill-line ()
 79        (Rtyo 33)(Rprinc "K"))
 80 
 81 ; Insert character string in line at current position.
 82 
 83 (defun DCTL-insert-char-string (str)
 84        (Rtyo 33)(Rprinc "Q")
 85        (Rprinc str)
 86        (Rtyo 33)(Rprinc "R")
 87        (setq X (+ X (stringlength str))))
 88 
 89 ; Delete characters from current position in line.
 90 
 91 (defun DCTL-delete-chars (n)
 92        (do i 1 (1+ i)(> i n)
 93            (Rtyo 33)(Rprinc "P")))
 94 
 95 ; Insert n blank lines at current position.
 96 
 97 (defun DCTL-insert-lines (n)
 98        (do i 1 (1+ i)(> i n)
 99            (Rtyo 33)(Rprinc "L")(DCTL-pad 50000.)))
100 
101 ; Delete n lines at current position.
102 
103 (defun DCTL-delete-lines (n)
104        (do i 1 (1+ i)(> i n)
105            (Rtyo 33)(Rprinc "M")(DCTL-pad 50000.)))
106 
107 ; Send pad characters to wait specified no. of microseconds.
108 
109 (defun DCTL-pad (n)
110        (do i (// (* n ospeed) 1000000.) (1- i) (= i 0)
111            (Rtyo 0)))