1
2
3
4
5
6
7
8
9
10
11
12
13
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))
44 (and (= y Y)
45 (progn
46 (cond ((< X x)
47 (cond ((not DCTLV-tabs-availablep)
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)
57 (return nil)))
58
59
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
71
72 (cond ((and (not (= targ-stops cur-stops))
73 (< (+ targ-rem
74 (* (- targ-stops cur-stops)
75 (+ DCTLV-consttab-pad
76 1
77 (fix (*$ 10e0 DCTLV-vartab-pad)))))
78 (- there here)))
79
80 (do tabx cur-stops (1+ tabx)(= tabx targ-stops)
81 (Rtyo 11)
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)))