1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17 (declare (special xconses yconses escfxconsesyconses X Y screenheight ospeed tty-type))
18 (declare (special idel-lines-availablep idel-chars-availablep screenlinelen))
19
20
21
22 (defun DCTL-init ()
23 (setq xconses (list nil nil))
24 (setq yconses (list nil nil))
25 (setq escfxconsesyconses (nconc (list (ascii 33) '& 'a)
26 xconses (list 'c)
27 yconses (list 'R)))
28 (setq screenheight 24.)
29 (setq screenlinelen 79.)
30 (setq idel-lines-availablep t idel-chars-availablep t)
31 (setq tty-type 'hp2645)
32 (Rtyo 33) (Rprinc "H")
33 (Rtyo 33) (Rprinc "J")
34 (setq X 0 Y 0))
35
36
37
38 (defun DCTL-position-cursor (x y)
39 (prog (ycost
40 xcost
41 what
42 cost)
43 (and (= x X)(= y Y)
44 (return nil))
45 (setq what 1
46 cost (+ 2 y x x))
47 (and (> cost 9)
48 (setq what 0
49 cost 9))
50 (setq ycost (- y Y))
51 (and (< ycost 0)
52 (setq ycost (* (- ycost) 2)))
53 (setq xcost (- X x))
54 (and (< xcost 0)
55 (setq xcost (* (- xcost) 2)))
56 (and (< (+ ycost xcost) cost)
57 (setq what 3
58 cost (+ ycost xcost)))
59 (and (< (+ 1 ycost x x) cost)
60 (setq what 2))
61 (cond ((= what 0)
62
63
64
65 (rplaca xconses (+ 60 (// x 10.)))
66 (rplaca (cdr xconses) (+ 60 (\ x 10.)))
67
68 (rplaca yconses (+ 60 (// y 10.)))
69 (rplaca (cdr yconses) (+ 60 (\ y 10.)))
70
71 (Rprinc (implode escfxconsesyconses))
72 (setq X x Y y)
73 (return nil))
74
75 ((= what 1)
76 (Rtyo 33)(Rprinc "H")
77 (setq X 0 Y 0))
78
79
80 ((= what 2)
81 (Rtyo 15)
82 (setq X 0)))
83
84
85
86
87 (cond ((< X x)
88 (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C")))
89 ((< x X)
90 (do ex x (1+ ex)(= ex X)(Rtyo 10))))
91 (cond ((< Y y)
92 (do wy Y (1+ wy)(= wy y)(Rtyo 12)))
93 ((< y Y)
94 (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A"))))
95 (setq X x Y y)
96 (return nil)))
97
98
99
100 (defun DCTL-display-char-string (string)
101 (setq X (+ X (stringlength string)))
102 (Rprinc string))
103
104
105
106 (defun DCTL-clear-rest-of-screen ()
107 (Rtyo 33)(Rprinc "J"))
108
109
110
111 (defun DCTL-kill-line ()
112 (Rtyo 33)(Rprinc "K"))
113
114
115
116 (defun DCTL-insert-char-string (str)
117 (Rtyo 33)(Rprinc "Q")
118 (Rprinc str)
119 (Rtyo 33)(Rprinc "R")
120 (setq X (+ X (stringlength str))))
121
122
123
124 (defun DCTL-delete-chars (n)
125 (do i 1 (1+ i)(> i n)
126 (Rtyo 33)(Rprinc "P")(DCTL-pad 7000.)))
127
128
129
130 (defun DCTL-insert-lines (n)
131 (do i 1 (1+ i)(> i n)
132 (Rtyo 33)(Rprinc "L")))
133
134
135
136 (defun DCTL-delete-lines (n)
137 (do i 1 (1+ i)(> i n)
138 (Rtyo 33)(Rprinc "M")))
139
140
141
142 (defun DCTL-pad (n)
143 (do i (// (* n ospeed) 1000000.) (1- i) (= i 0)
144 (Rtyo 0)))