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 ;;;
 11 ;;;       Printing tty display control
 12 ;;;       Redone for new redisplay 7/7/78
 13 ;;;       Large redo 8/9/78 for tabs, delays, and no screen knowledge.
 14 
 15 (declare (special X Y  screenheight idel-lines-availablep idel-chars-availablep screenlinelen tty-type tty-no-upmotionp overstrike-availablep))
 16 (declare (special DCTLV-vertnl-pad DCTLV-horznl-pad DCTLV-consttab-pad DCTLV-vartab-pad DCTLV-tabs-availablep DCTLV-backspace-pad DCTLV-one-time-bspad))
 17 (declare (defpl1 e_pl1_$get_mcs_tty_info "" (return bit (1))(return float bin)(return fixed bin)
 18          (return float bin)(return fixed bin)(return fixed bin)(return fixed bin)))
 19 
 20 
 21 (defun DCTL-init ()
 22    (setq X -777 Y -777)
 23    (setq tty-type 'printing)
 24    (setq screenheight 60.)
 25    (setq idel-chars-availablep nil idel-lines-availablep nil tty-no-upmotionp t overstrike-availablep t)
 26    ((lambda (result)
 27             (setq DCTLV-tabs-availablep (not (zerop (car result))) result (cdr result))
 28             (setq DCTLV-horznl-pad (car result) result (cdr result))
 29             (setq DCTLV-vertnl-pad (abs (car result)) result (cdr result))
 30             (setq DCTLV-vartab-pad (car result) result (cdr result))
 31             (setq DCTLV-consttab-pad (car result) result (cdr result))
 32             (setq DCTLV-backspace-pad (car result) screenlinelen (cadr result)))
 33     (e_pl1_$get_mcs_tty_info))
 34    (setq screenlinelen (cond ((= screenlinelen 79.) 79.)
 35                              (t (1- screenlinelen))))
 36    (setq DCTLV-one-time-bspad
 37          (cond ((< DCTLV-backspace-pad 0)(prog2 0 (- DCTLV-backspace-pad)(setq DCTLV-backspace-pad 0)))
 38                (t 0))))
 39 
 40 (defun DCTL-position-cursor (x y)
 41    (prog ()
 42     (and (= x X)(= y Y)(return nil))
 43     (and (< X 0)(DCTL-crlf))            ;unrandomize
 44     (and (= y Y)
 45          (progn
 46           (cond ((< X x)                          ;going forward
 47                  (cond ((not DCTLV-tabs-availablep)    ;no tabs
 48                         (do xx X (1+ xx)(= xx x)(Rtyo 40)))
 49                        (t (DCTL-tab-forward X x))))
 50                  ((< (- X x) x)
 51                   (DCTL-delay DCTLV-one-time-bspad)
 52                   (do xx X (1- xx)(= xx x)(Rtyo 10)
 53                               (DCTL-delay DCTLV-backspace-pad)))
 54                  (t (DCTL-cret)
 55                     (DCTL-position-cursor x Y)))
 56           (setq X x)    ;y is right by definition
 57           (return nil)))
 58 
 59           ;; Definitely going to a new line at this point
 60 
 61       (DCTL-nextline)
 62     (setq Y y)
 63     (DCTL-position-cursor x y)))
 64 
 65 (defun DCTL-tab-forward (here there)
 66    (prog (targ-stops targ-rem cur-stops)
 67        (setq targ-stops (// there 10.) targ-rem (\ there 10.))
 68        (setq cur-stops (// here 10.))
 69        ;;
 70        ;;  Figure out the relative costs.
 71        ;;
 72        (cond ((and (not (= targ-stops cur-stops)) ;dont even bother
 73                    (< (+ targ-rem                 ;spaces to be output
 74                          (* (- targ-stops cur-stops)   ;number of tabs
 75                             (+ DCTLV-consttab-pad ;constant padding
 76                                1                  ;the actual tab
 77                                (fix (*$ 10e0 DCTLV-vartab-pad)))))
 78                       (- there here)))            ;normal cost
 79                                                   ;do it
 80               (do tabx cur-stops (1+ tabx)(= tabx targ-stops)
 81                     (Rtyo 11)                     ;tab
 82                     (DCTL-delay (+ DCTLV-consttab-pad (fix (*$ 10e0 DCTLV-vartab-pad)))))
 83               (setq here (* targ-stops 10.))))
 84        (do xx here (1+ xx)(= xx there)(Rtyo 40))))
 85 
 86 
 87 (defun DCTL-assert-scpos (x y)
 88        (and x (setq X x))
 89        (and y (setq Y y)))
 90 
 91 (defun DCTL-clear-rest-of-screen ()(DCTL-nextline))
 92 
 93 (defun DCTL-nextline ()(Rtyo 12)(DCTL-delay DCTLV-vertnl-pad))
 94 
 95 (defun DCTL-kill-line ()(Rtyo 12)(DCTL-delay DCTLV-vertnl-pad))
 96 
 97 (defun DCTL-display-char-string (s)
 98      (Rprinc s)
 99      (setq X (+ X (stringlength s))))
100 
101 (defun DCTL-cret ()
102      (Rtyo 15)(DCTL-delay (+ 3 (fix (*$ (float X) DCTLV-horznl-pad))))(setq X 0))
103 
104 (defun DCTL-crlf ()
105      (DCTL-cret)(DCTL-nextline))
106 
107 (defun DCTL-delay (n)
108    (do i 1 (1+ i)(> i n)(Rtyo 177)))