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 ;;;       Glass tty display control
12 ;;;       From printing tty, BSG 6/29/78
13 ;;;       Redone for new redisplay 7/7/78
14 ;;;       For tty-no-cleolp, bsg 2/14/80
15 
16 (declare (special X Y  screenheight idel-lines-availablep idel-chars-availablep screenlinelen tty-type tty-no-upmotionp tty-no-cleolp))
17 (declare (array* (notype (newscreen ?))))
18 
19 (defun DCTL-init ()
20    (setq X -777 Y -777)
21    (setq tty-type 'teleray)
22    (setq screenheight 24. screenlinelen 79.)
23    (setq idel-chars-availablep nil idel-lines-availablep nil tty-no-upmotionp t tty-no-cleolp t))
24 
25 (defun DCTL-position-cursor (x y)
26  (prog ()
27     (and (= x X)(= y Y)(return nil))
28     (and (< X 0)(DCTL-crlf))
29     (and (= y Y)
30          (progn
31           (cond ((and (= x 0)(> X 4))(DCTL-cret))
32                 ((< X x)(DCTL-display-char-string
33                               (substr (or (cadr (newscreen Y)) "          ") (1+ X) (- x X))))
34                  ((< (- X x) x) (do xx X (1- xx)(= xx x)(Rtyo 10)))
35                  (t (DCTL-cret)
36                     (DCTL-position-cursor x Y)))
37           (setq X x)    ;y is right by definition
38           (return nil)))
39 
40           ;; Definitely going to a new line at this point
41 
42     (DCTL-nextline)
43     (setq Y y)
44     (DCTL-position-cursor x y)))
45 
46 (defun DCTL-assert-scpos (x y)
47        (and x (setq X x))
48        (and y (setq Y y)))
49 
50 (defun DCTL-clear-rest-of-screen ())
51 
52 (defun DCTL-nextline ()(Rtyo 12))
53 
54 (defun DCTL-display-char-string (s)
55      (Rprinc s)
56      (setq X (+ X (stringlength s))))
57 
58 (defun DCTL-cret ()
59      (Rtyo 15)(setq X 0))
60 
61 (defun DCTL-crlf ()
62      (Rtyo 15)(Rtyo 12)(setq X 0))