-
Notifications
You must be signed in to change notification settings - Fork 0
/
CD2LB.R
2177 lines (1845 loc) · 44.8 KB
/
CD2LB.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
###############################################################################
#
# C D 2 L B
# Craig's Display Library
#
###############################################################################
#
# Modification History
# ------------ -------
# 03m 11Sep84 cal .Renamed include files "cdlb" and "cdlb.c" to "cddef" and
# "cdcom". Removed some unused variables.
# 03l 16Jul84 cal .Modified to use new iolb routine names.
# 03k 08Jun84 cal .Changed cdend() to position the cursor.
# 03j 20Apr84 cal .Added requirements of minimum terminal capabilities to
# cdinit().
# 03i 11Mar84 cal .Fixed bug in cdgetp() that precluded clear to end of line
# from being used.
# 03h 22Feb84 cal .Added cdgetp() which gets a string with a default and
# modified cdgetx() to use it.
# 03g 14Dec83 cal .Modified cdclra() to accept points in any order. Removed
# definition of NOIMPLICIT. Removed several unused variables.
# 03f 23Sep83 cal .Added a portable version of cdfill() and cdmovtc() and
# removed fast macro conditional code. Changed cdinit() to
# not call cdmaketc(). Added cdbox(). Changed to use
# scdisp(). Modified cdgetx() to accept carriage return as
# a valid terminator if no terminators are specified.
# Speeded up loop in cdplay(). Modified cdline() to accept
# points in any order.
# 03e 10Sep83 cal .Modified cdplay() to keep track of the last line it
# updated. Renamed fillch(), movtchs(), and maktbl()
# to cdfill(), cdmovtc(), and cdmaketc(). Removed cdget(),
# cdgetk(), and cdpeek() since they duplicate scget(),
# scgetk(), scpeek(). Removed cdlredo() since cdlb is not
# for hardcopy terminals. Reformatted routine headers.
# 03d 05Sep83 cal .Created cdsetfont(), which contains some code moved
# out from cdcput(). Modified all routines that deal with
# fonts to always treat them as characters.
# 03c 14Jul83 cal .Ratfix.
# 03b 10Jul83 cal .Modified to not use cursor right, but rather put
# out the character that is really on the screen.
# 03a 29May83 cal .Rewritten to go like hell
#
###############################################################################
include "sclb"
include "sclb.i"
include "cddef"
define(MSGMAXLINE,90) # used for screen formatting
define(NORMAL_FONT,0) # normal font (must be 0)
#define(DEBUG_CDLB,) # uncomment this to get debug code
# abbreviations
define(T,.true.)
define(F,.false.)
# Macro to calculate relative cursor movement costs.
#
# cost = cdcrel(olin, ocol, nlin, ncol)
# ( colcost(ncol-ocol) + lincost(nlin-olin) )
#
define(cdcrel,(colcost($4-$2)+lincost($3-$1)))
# Special characters (for building boxes).
define(LSCH_MIN,1)
define(LSCH_MAX,15)
define(LSCH_D,1)
define(LSCH_L,2)
define(LSCH_LD,3)
define(LSCH_U,4)
define(LSCH_UD,5)
define(LSCH_UL,6)
define(LSCH_ULD,7)
define(LSCH_R,8)
define(LSCH_RD,9)
define(LSCH_RL,10)
define(LSCH_RLD,11)
define(LSCH_RU,12)
define(LSCH_RUD,13)
define(LSCH_RUL,14)
define(LSCH_RULD,15)
### cdacel - clear to end of line (internal)
#
# synopsis
#
# integer lin, col
# call cdacel ( lin, col )
#
# lin - line number
# col - column number
#
subroutine cdacel ( lin, col )
NOIMPLICIT
integer lin, col
integer j
include "cdcom"
# Actually clear to end of line.
call cdgoto ( lin, col )
call sccel
# Fix up internal image.
j = maxcol - col + 1 # number of characters
call cdfill ( ' ', aimage(col,lin), j )
call cdfill ( NORMAL_FONT, afont(col,lin), j )
changed(lin) = .true.
alinend(lin) = 0
firstcol(lin) = min0 ( firstcol(lin), col )
return
end
### cdandfont - make font containing anything in both of two fonts
#
# synopsis
#
# character font, cdandfont, font1, font2
# font = cdandfont ( font1, font2 )
#
# font1 - a font
# font2 - a font
# font - returned font
#
character function cdandfont ( font1, font2 )
NOIMPLICIT
character font1, font2
return ( font1 & font2 )
end
### cdaput - put character on actual image (internal)
#
# synopsis
#
# character ch, f
# integer lin, col
# call cdaput ( ch, f, lin, col )
#
# ch - character to output
# f - font for character
# lin - line number
# col - line column
#
subroutine cdaput ( ch, f, lin, col )
NOIMPLICIT
character ch, f
integer lin, col
include "cdcom"
include "sclb.c"
# Move cursor.
call cdgoto ( lin, col )
# Put the character out.
call cdcput ( ch, f )
# Update image of screen.
aimage(col,lin) = ch
afont(col,lin) = f
changed(lin) = .true.
alinend(lin) = max0 ( alinend(lin), col )
firstcol(lin) = min0 ( firstcol(lin), col )
# Compute new cursor position.
if ( acol < maxcol )
acol = acol + 1
else
{
# At last character of line.
if ( scautonl )
{
acol = 1
alin = alin + 1
}
}
return
end
### cdbox - draw a box
#
# synopsis
#
# integer lin1, col1, lin2, col2
# call cdbox ( lin1, col1, lin2, col2 )
#
# lin1 - first line number
# col1 - first column number
# lin2 - last line number
# col2 - last column number
#
# description
#
# This routine draws a box defined by the two points.
#
subroutine cdbox ( lin1, col1, lin2, col2 )
NOIMPLICIT
integer lin1, col1, lin2, col2
call cdline ( lin1, col1, lin1, col2 ) # right
call cdline ( lin1, col2, lin2, col2 ) # down
call cdline ( lin2, col2, lin2, col1 ) # left
call cdline ( lin2, col1, lin1, col1 ) # up
return
end
### cdcput - output a character (internal)
#
# synopsis
#
# character ch, f
# call cdcput ( ch, f )
#
# ch - character to output
# f - font for character
#
subroutine cdcput ( ch, f )
NOIMPLICIT
character ch, f
include "cdcom"
# Set up correct font.
if ( f != afontc )
call cdsetfont ( f )
# Put character on screen.
switch ( ch )
{
case LSCH_D:
call scgraphics ( LSEG_D )
case LSCH_L:
call scgraphics ( LSEG_L )
case LSCH_LD:
call scgraphics ( LSEG_LD )
case LSCH_U:
call scgraphics ( LSEG_U )
case LSCH_UD:
call scgraphics ( LSEG_UD )
case LSCH_UL:
call scgraphics ( LSEG_UL )
case LSCH_ULD:
call scgraphics ( LSEG_ULD )
case LSCH_R:
call scgraphics ( LSEG_R )
case LSCH_RD:
call scgraphics ( LSEG_RD )
case LSCH_RL:
call scgraphics ( LSEG_RL )
case LSCH_RLD:
call scgraphics ( LSEG_RLD )
case LSCH_RU:
call scgraphics ( LSEG_RU )
case LSCH_RUD:
call scgraphics ( LSEG_RUD )
case LSCH_RUL:
call scgraphics ( LSEG_RUL )
case LSCH_RULD:
call scgraphics ( LSEG_RULD )
case CDLB_PILLOW:
# Pillow character.
call scpillow
default:
# Put normal character on screen.
call scput ( ch )
}
return
end
### cdclear - clear the desired image
#
# synopsis
#
# call cdclear
#
subroutine cdclear
NOIMPLICIT
include "cdcom"
# Clear the desired image.
call cdclra ( 1, 1, maxlin, maxcol )
# Force normal font.
call cdsetfont ( NORMAL_FONT )
return
end
### cdclra - clear rectangular area in desired image
#
# synopsis
#
# integer l1, c1, l2, c2
# call cdclra ( l1, c1, l2, c2 )
#
# l1 - first line to clear
# c1 - first column to clear
# l2 - last line to clear
# c2 - last column to clear
#
# description
#
# This routine clears (to blanks in the normal font) all characters
# in the desired image contained within the rectangle defined by
# the two points.
#
subroutine cdclra ( l1, c1, l2, c2 )
NOIMPLICIT
integer l1, c1, l2, c2
integer i, j, rfc, rlc, rfl, rll
include "cdcom"
rfc = max0 ( 1, min0 ( c1, c2 ) )
rlc = min0 ( maxcol, max0 ( c1, c2 ) )
# Calculate length.
j = rlc - rfc + 1
rfl = max0 ( 1, min0 ( l1, l2 ) )
rll = min0 ( maxlin, max0 ( l1, l2 ) )
for ( i = rfl ; i <= rll ; i = i + 1 )
{
call cdfill ( ' ', dimage(rfc,i), j )
call cdfill ( NORMAL_FONT, dfont(rfc,i), j )
changed(i) = .true.
# Update beginning and end of line info.
if ( rlc >= dlinend(i) )
dlinend(i) = min0 ( dlinend(i), rfc - 1 )
firstcol(i) = min0 ( firstcol(i), rfc )
}
return
end
### cdclrl - clear lines in desired image
#
# synopsis
#
# integer f, n
# call cdclrl ( f, n )
#
# f - the first line to clear
# n - the number of lines to clear
#
subroutine cdclrl ( f, n )
NOIMPLICIT
integer f, n
integer i
include "cdcom"
i = f + n - 1
if ( i > 0 )
call cdclra ( f, 1, i, maxcol )
return
end
### cdcols - return the number of columns for this terminal
#
# synopsis
#
# integer cols, cdcols
# cols = cdcols ( 0 )
#
# cols - number of columns
#
integer function cdcols ( dummy )
NOIMPLICIT
integer dummy
include "cdcom"
return ( maxcol )
end
### cddefont - decode font character (internal)
#
# synopsis
#
# character f
# logical att(MAX_ATTRIBUTES)
# call cddefont ( f, att )
#
# f - font character
# att - character attributes vector
#
subroutine cddefont ( f, att )
NOIMPLICIT
character f
logical att(MAX_ATTRIBUTES)
integer i
logical ht ( 64 )
logical ut ( 64 )
logical rt ( 64 )
logical bt ( 64 )
logical gt ( 64 )
logical at ( 64 )
data ht /F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,
F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T/
data ut /F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,
F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T/
data rt /F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T,
F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T/
data bt /F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T,F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T,
F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T,F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T/
data gt /F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,
F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T/
data at /F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,F,
T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T/
i = f + 1
att ( ATTRIBUTE_HIGHLIGHT ) = ht ( i )
att ( ATTRIBUTE_UNDERLINE ) = ut ( i )
att ( ATTRIBUTE_REVERSE ) = rt ( i )
att ( ATTRIBUTE_BLINK ) = bt ( i )
att ( ATTRIBUTE_GRAPHICS ) = gt ( i )
att ( ATTRIBUTE_ALTERNATE ) = at ( i )
return
end
### cdend - end display environment
#
# synopsis
#
# call cdend
#
# description
#
# This must be the last routine called from cdlb.
#
subroutine cdend
NOIMPLICIT
include "cdcom"
include "sclb.c"
if ( sccikey != CANT & sccokey != CANT )
call scokey
if ( sccmove != CANT )
if ( alin != maxlin | acol != 1 )
call scmove ( maxlin, 1 )
call scend
return
end
### cdfill - fill buffer (portable version)
#
# synopsis
#
# character ch, buf()
# integer count
# call cdfill ( ch, buf, count )
#
# ch - character to fill with
# buf - buffer to fill
# count - fill count
#
subroutine cdfill ( ch, buf, count )
NOIMPLICIT
character ch, buf(ARB)
integer count
integer i
for ( i = 1; i <= count; i = i + 1 )
buf(i) = ch
end
### cdfont - set desired font
#
# synopsis
#
# character f
# call cdfont ( f )
#
# f - new desired font
#
subroutine cdfont ( f )
NOIMPLICIT
character f
include "cdcom"
dfontc = f
return
end
### cdgetn - read a number from the terminal
#
# synopsis
#
# character pmt()
# integer status, cdgetn, num, lin, col
# status = cdgetn ( pmt, lin, col, num )
#
# pmt - prompt string
# lin - line number
# col - column number
# num - number read
# status - OK if a number was read, else ERR
#
integer function cdgetn ( pmt, lin, col, num )
NOIMPLICIT
character pmt(ARB)
integer num, lin, col
character buf(MSGMAXLINE)
integer i, cdgets, ctoi
if ( cdgets ( pmt, lin, col, buf, MSGMAXLINE ) == ERR )
return ( ERR )
i = 1
num = ctoi ( buf, i )
return ( OK )
end
### cdgets - read a line from the terminal
#
# synopsis
#
# character pmt(), str()
# integer status, cdgets, maxlen, lin, col
# status = cdgets ( pmt, lin, col, str, maxlen )
#
# pmt - prompt string
# lin - line number to display prompt
# col - column number to display prompt
# str - returned string
# maxlen - size of str
#
# description
#
# A line is read from the terminal and returned in str. A maximum of
# maxlen characters will be put into the string, although more may be
# read. Characters are read up to a newline or linefeed.
#
# You can erase characters with either delete or backspace. You can
# erase the line with either control-x or control-u. You can erase
# the last word with control-w. You can redisplay the screen with
# control-l.
#
integer function cdgets ( pmt, lin, col, str, maxlen )
NOIMPLICIT
character pmt(ARB), str(ARB)
integer maxlen, lin, col
integer length
character cdgetx
character termch
string terms "@^m@^j"
termch = cdgetx ( pmt, lin, col, terms, str, maxlen )
if ( length ( str ) == 0 )
cdgets = ERR
else
cdgets = OK
return
end
###############################################################################
#
### cdgetx - read a line from the terminal with special terminators
#
# synopsis
#
# character pmt(), terms(), str()
# integer maxlen, lin, col
# character termch, cdgetx
# termch = cdgetx ( pmt, lin, col, terms, str, maxlen )
#
# pmt - prompt string
# lin - line number to display prompt
# col - column number to display prompt
# terms - string of acceptable line terminators
# str - returned string
# maxlen - size of str
# termch - the terminating character
#
# description
#
# This routine prompts for input from the terminal using ``pmt''. The
# input string is returned in ``str''. A maximum of maxlen characters
# will be put into the string, although more may be read. Characters
# are read up to one of the terminator characters in the string
# ``terms''. If ``terms'' is an empty string, carriage return is
# allowed as a terminator.
#
# You can erase characters with either delete or backspace. You can
# erase the line with either control-x or control-u. You can erase
# the last word with control-w. You can redisplay the screen with
# control-l.
#
# The terminating character is returned as value.
#
character function cdgetx ( pmt, lin, col, terms, str, maxlen )
NOIMPLICIT
character pmt(ARB), terms(ARB), str(ARB)
integer maxlen, lin, col
character cdgetp
str(1) = EOS
return ( cdgetp ( pmt, lin, col, terms, str, maxlen ) )
end
###############################################################################
#
### cdgetp - read a line from the terminal with special terminators
#
# synopsis
#
# character pmt(), terms(), str()
# integer maxlen, lin, col
# character termch, cdgetx
# termch = cdgetp ( pmt, lin, col, terms, str, maxlen )
#
# pmt - prompt string
# lin - line number to display prompt
# col - column number to display prompt
# terms - string of acceptable line terminators
# str - passed and returned string
# maxlen - size of str
# termch - the terminating character
#
# description
#
# This routine prompts for input from the terminal. The prompt ``pmt''
# and initial contents of ``str'' and displayed and then input is read
# and the result is returned in ``str''. This means that a default value
# of str can be provided. This routine is otherwise similar to cdgetx().
#
character function cdgetp ( pmt, lin, col, terms, str, maxlen )
NOIMPLICIT
character pmt(ARB), terms(ARB), str(ARB)
integer maxlen, lin, col
integer i, len, icol, scol, imaxlen, length, index
character ch, iogchar
logical scdisp
include "cdcom"
include "sclb.c"
call cdputs ( pmt, lin, col )
scol = col + length ( pmt )
call cdputs ( str, lin, scol )
len = length ( str )
icol = scol + len
if ( scautonl & lin == maxlin )
i = maxcol - 1
else
i = maxcol
imaxlen = min0 ( maxlen, maxcol - scol + 1 )
repeat
{
str( min0 ( len+1, imaxlen ) ) = EOS
call cdmove ( lin, icol )
call cdplay ( .true. )
ch = iogchar ( ch )
if ( terms(1) != EOS )
if ( index ( terms, ch ) != 0 )
break
else if ( ch == '@^m' )
break
if ( ch == '@^h' | ch == '@^?' )
{
# Delete one character.
if ( len > 0 )
{
len = len - 1
icol = icol - 1
call cdclra ( lin, icol, lin, icol )
}
}
else if ( ch == '@^w' )
{
# Delete the last word.
if ( len > 0 )
{
# Back up over blanks.
i = icol # remember the end
while ( len > 0 )
if ( str(len) == ' ' )
{
icol = icol - 1
len = len - 1
}
else
break
# Back up over non-blanks.
while ( len > 0 )
if ( str(len) == ' ' )
break
else
{
icol = icol - 1
len = len - 1
}
# Clear things in the actual image, if necessary.
if ( icol < i )
call cdclra ( lin, icol, lin, i - 1 )
}
}
else if ( ch == '@^u' | ch == '@^x' )
{
if ( len > 0 )
{
call cdclra ( lin, scol, lin, icol - 1 )
icol = scol
len = 0
}
}
else if ( ch == '@^l' )
call cdredo
else if ( ! scdisp ( ch ) )
call iobeep
else if ( len + 1 < imaxlen )
{
len = len + 1
str(len) = ch
call cdput ( ch, lin, icol )
icol = icol + 1
}
else
call iobeep
}
str( min0 ( len+1, imaxlen ) ) = EOS
return ( ch )
end
### cdgfont - get the current font
#
# synopsis
#
# character font, cdgfont
# font = cdgfont ( 0 )
#
# font - the current font
#
character function cdgfont ( dummy )
NOIMPLICIT
integer dummy
include "cdcom"
return ( dfontc )
end
### cdgoto - move the cursor optimally (internal)
#
# synopsis
#
# integer lin, col
# call cdgoto ( lin, col )
#
# lin - line number
# col - column number
#
# description
#
# This routine chooses a cursor movement strategy by comparing
# character costs. Currently, it uses the following strategies:
#
# - absolute cursor addressing
# - relative cursor movement
# - a carriage return plus relative movement
# - a cursor-home plus relative movement
#
# Special note: relative cursor movement to the right usually
# costs only one character per position moved, even on terminals
# whose cursor-right commands are more than one character long.
# This is because movement to the right is accomplished by re-typing
# the characters that are already in the positions being moved over.
# The exception to this is when the character has attributes other
# than the current ones set.
#
subroutine cdgoto ( lin, col )
NOIMPLICIT
integer lin, col
integer i, strat, cost, thiscost
include "cdcom"
include "sclb.c"
# 'A' means absolute movement.
# 'R' means relative cursor movement.
# 'N' means newline plus relative movement.
# 'H' means home plus relative movement.
# There's a good chance we're already where we want to be.
if ( lin == alin & col == acol )
return
# The default moving strategy is absolute cursor positioning.
strat = 'A'
cost = sccmove
# Compute and compare the cost of relative cursor positioning.
thiscost = cdcrel(alin, acol, lin, col)
if ( thiscost <= cost ) # Could be <, but <= makes it more interesting.
{
strat = 'R'
cost = thiscost
}
if ( acol != 1 ) # If we are not already in the first column...
{
# Compute the cost of a CR followed by relative positioning.
thiscost = sccbol + cdcrel(alin, 1, lin, col)
if ( thiscost <= cost )
{
strat = 'N'
cost = thiscost
}
if ( alin != 1 ) # If we are not already at home...
{
# Compute the cost of a home followed by relative positioning.
thiscost = scchome + cdcrel(1, 1, lin, col)
if ( thiscost <= cost )
{
strat = 'H'
cost = thiscost
}
}
}
# Now execute whatever strategy was decided on.
if ( strat == 'A' )
call scmove ( lin, col )
else
{
# Some form of relative movement.
if ( strat == 'N' )
{
call scbol
acol = 1
}
else if ( strat == 'H' )
{
call schome
alin = 1
acol = 1
}
if ( col < acol )
call scleft ( acol-col )
else if ( col > acol )
{
# Put out characters from the actual image to move.
# the cursor right, if we're in the correct font.
# Otherwise, use relative cursor movement.
for ( i = acol; i < col; i = i + 1 )
if ( afontc == afont(i,alin) )
call cdcput ( aimage(i,alin), afont(i,alin) )
else
call scright ( 1 )
}
if ( lin < alin )
call scup ( alin-lin )
else if ( lin > alin )
call scdown ( lin-alin )
}
alin = lin
acol = col
return
end
### cdicll - clear lines of internal image (internal)
#
# synopsis
#
# integer f, l
# call cdicll ( f, l )
#
# f - the first line in the area to clear
# l - the last line in the area to clear
#
subroutine cdicll ( f, l )
NOIMPLICIT
integer f, l
integer i
include "cdcom"
for ( i = f ; i <= l ; i = i + 1 )
{
call cdfill ( ' ', aimage(1,i), maxcol )
call cdfill ( NORMAL_FONT, afont(1,i), maxcol )
changed(i) = .true.
alinend(i) = 0
firstcol(i) = 1
}
return
end
### cdinit - initialize cdlb
#
# synopsis
#
# call cdinit
#
# description
#
# This routine must be called before all others in cdlb.
#
subroutine cdinit
NOIMPLICIT
integer i
logical scdisp
integer ich
character ch
equivalence (ich, ch)
include "cdcom"
include "sclb.c"
# Initialize screen library (this MUST be done first).
call scinit
# Impose minimum terminal requirements.
if ( schardcopy )
{
call scend
call error ( "cdinit: You cannot run from a hardcopy terminal." )
}