1 # Wrappers around print primitives that take a 'screen' object and are thus
  2 # easier to test.
  3 
  4 container screen [
  5   num-rows:num
  6   num-columns:num
  7   cursor-row:num
  8   cursor-column:num
  9   data:&:@:screen-cell
 10 ]
 11 
 12 container screen-cell [
 13   contents:char
 14   color:num
 15 ]
 16 
 17 def new-fake-screen w:num, h:num -> result:&:screen [
 18   local-scope
 19   load-ingredients
 20   result <- new screen:type
 21   bufsize:num <- multiply w, h
 22   data:&:@:screen-cell <- new screen-cell:type, bufsize
 23   *result <- merge h/num-rows, w/num-columns, 0/cursor-row, 0/cursor-column, data
 24   result <- clear-screen result
 25 ]
 26 
 27 def clear-screen screen:&:screen -> screen:&:screen [
 28   local-scope
 29   load-ingredients
 30   {
 31     break-if screen
 32     # real screen
 33     clear-display
 34     return
 35   }
 36   # fake screen
 37   buf:&:@:screen-cell <- get *screen, data:offset
 38   max:num <- length *buf
 39   i:num <- copy 0
 40   {
 41     done?:bool <- greater-or-equal i, max
 42     break-if done?
 43     curr:screen-cell <- merge 0/empty, 7/white
 44     *buf <- put-index *buf, i, curr
 45     i <- add i, 1
 46     loop
 47   }
 48   # reset cursor
 49   *screen <- put *screen, cursor-row:offset, 0
 50   *screen <- put *screen, cursor-column:offset, 0
 51 ]
 52 
 53 def sync-screen screen:&:screen -> screen:&:screen [
 54   local-scope
 55   load-ingredients
 56   return-if screen  # do nothing for fake screens
 57   sync-display
 58 ]
 59 
 60 def fake-screen-is-empty? screen:&:screen -> result:bool [
 61   local-scope
 62   load-ingredients
 63   return-unless screen, 1/true  # do nothing for real screens
 64   buf:&:@:screen-cell <- get *screen, data:offset
 65   i:num <- copy 0
 66   len:num <- length *buf
 67   {
 68     done?:bool <- greater-or-equal i, len
 69     break-if done?
 70     curr:screen-cell <- index *buf, i
 71     curr-contents:char <- get curr, contents:offset
 72     i <- add i, 1
 73     loop-unless curr-contents
 74     # not 0
 75     return 0/false
 76   }
 77   return 1/true
 78 ]
 79 
 80 def print screen:&:screen, c:char -> screen:&:screen [
 81   local-scope
 82   load-ingredients
 83   color:num, color-found?:bool <- next-ingredient
 84   {
 85     # default color to white
 86     break-if color-found?
 87     color <- copy 7/white
 88   }
 89   bg-color:num, bg-color-found?:bool <- next-ingredient
 90   {
 91     # default bg-color to black
 92     break-if bg-color-found?
 93     bg-color <- copy 0/black
 94   }
 95   c2:num <- character-to-code c
 96   trace 90, [print-character], c2
 97   {
 98     # real screen
 99     break-if screen
100     print-character-to-display c, color, bg-color
101     return
102   }
103   # fake screen
104   # (handle special cases exactly like in the real screen)
105   width:num <- get *screen, num-columns:offset
106   height:num <- get *screen, num-rows:offset
107   # if cursor is out of bounds, silently exit
108   row:num <- get *screen, cursor-row:offset
109   row <- round row
110   legal?:bool <- greater-or-equal row, 0
111   return-unless legal?
112   legal? <- lesser-than row, height
113   return-unless legal?
114   column:num <- get *screen, cursor-column:offset
115   column <- round column
116   legal? <- greater-or-equal column, 0
117   return-unless legal?
118   legal? <- lesser-than column, width
119   return-unless legal?
120 #?     $print [print-character (], row, [, ], column, [): ], c, 10/newline
121   # special-case: newline
122   {
123     newline?:bool <- equal c, 10/newline
124     break-unless newline?
125     {
126       # unless cursor is already at bottom
127       bottom:num <- subtract height, 1
128       at-bottom?:bool <- greater-or-equal row, bottom
129       break-if at-bottom?
130       # move it to the next row
131       column <- copy 0
132       *screen <- put *screen, cursor-column:offset, column
133       row <- add row, 1
134       *screen <- put *screen, cursor-row:offset, row
135     }
136     return
137   }
138   # save character in fake screen
139   index:num <- multiply row, width
140   index <- add index, column
141   buf:&:@:screen-cell <- get *screen, data:offset
142   len:num <- length *buf
143   # special-case: backspace
144   {
145     backspace?:bool <- equal c, 8
146     break-unless backspace?
147     {
148       # unless cursor is already at left margin
149       at-left?:bool <- lesser-or-equal column, 0
150       break-if at-left?
151       # clear previous location
152       column <- subtract column, 1
153       *screen <- put *screen, cursor-column:offset, column
154       index <- subtract index, 1
155       cursor:screen-cell <- merge 32/space, 7/white
156       *buf <- put-index *buf, index, cursor
157     }
158     return
159   }
160   cursor:screen-cell <- merge c, color
161   *buf <- put-index *buf, index, cursor
162   # increment column unless it's already all the way to the right
163   {
164     right:num <- subtract width, 1
165     at-right?:bool <- greater-or-equal column, right
166     break-if at-right?
167     column <- add column, 1
168     *screen <- put *screen, cursor-column:offset, column
169   }
170 ]
171 
172 scenario print-character-at-top-left [
173   local-scope
174   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
175   run [
176     a:char <- copy 97/a
177     fake-screen <- print fake-screen, a:char
178     cell:&:@:screen-cell <- get *fake-screen, data:offset
179     1:@:screen-cell/raw <- copy *cell
180   ]
181   memory-should-contain [
182     1 <- 6  # width*height
183     2 <- 97  # 'a'
184     3 <- 7  # white
185     # rest of screen is empty
186     4 <- 0
187   ]
188 ]
189 
190 scenario print-character-at-fractional-coordinate [
191   local-scope
192   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
193   a:char <- copy 97/a
194   run [
195     move-cursor fake-screen, 0.5, 0
196     fake-screen <- print fake-screen, a:char
197     cell:&:@:screen-cell <- get *fake-screen, data:offset
198     1:@:screen-cell/raw <- copy *cell
199   ]
200   memory-should-contain [
201     1 <- 6  # width*height
202     2 <- 97  # 'a'
203     3 <- 7  # white
204     # rest of screen is empty
205     4 <- 0
206   ]
207 ]
208 
209 scenario print-character-in-color [
210   local-scope
211   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
212   run [
213     a:char <- copy 97/a
214     fake-screen <- print fake-screen, a:char, 1/red
215     cell:&:@:screen-cell <- get *fake-screen, data:offset
216     1:@:screen-cell/raw <- copy *cell
217   ]
218   memory-should-contain [
219     1 <- 6  # width*height
220     2 <- 97  # 'a'
221     3 <- 1  # red
222     # rest of screen is empty
223     4 <- 0
224   ]
225 ]
226 
227 scenario print-backspace-character [
228   local-scope
229   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
230   a:char <- copy 97/a
231   fake-screen <- print fake-screen, a
232   run [
233     backspace:char <- copy 8/backspace
234     fake-screen <- print fake-screen, backspace
235     10:num/raw <- get *fake-screen, cursor-column:offset
236     cell:&:@:screen-cell <- get *fake-screen, data:offset
237     11:@:screen-cell/raw <- copy *cell
238   ]
239   memory-should-contain [
240     10 <- 0  # cursor column
241     11 <- 6  # width*height
242     12 <- 32  # space, not 'a'
243     13 <- 7  # white
244     # rest of screen is empty
245     14 <- 0
246   ]
247 ]
248 
249 scenario print-extra-backspace-character [
250   local-scope
251   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
252   a:char <- copy 97/a
253   fake-screen <- print fake-screen, a
254   run [
255     backspace:char <- copy 8/backspace
256     fake-screen <- print fake-screen, backspace
257     fake-screen <- print fake-screen, backspace  # cursor already at left margin
258     1:num/raw <- get *fake-screen, cursor-column:offset
259     cell:&:@:screen-cell <- get *fake-screen, data:offset
260     3:@:screen-cell/raw <- copy *cell
261   ]
262   memory-should-contain [
263     1 <- 0  # cursor column
264     3 <- 6  # width*height
265     4 <- 32  # space, not 'a'
266     5 <- 7  # white
267     # rest of screen is empty
268     6 <- 0
269   ]
270 ]
271 
272 scenario print-character-at-right-margin [
273   # fill top row of screen with text
274   local-scope
275   fake-screen:&:screen <- new-fake-screen 2/width, 2/height
276   a:char <- copy 97/a
277   fake-screen <- print fake-screen, a
278   b:char <- copy 98/b
279   fake-screen <- print fake-screen, b
280   run [
281     # cursor now at right margin
282     c:char <- copy 99/c
283     fake-screen <- print fake-screen, c
284     10:num/raw <- get *fake-screen, cursor-column:offset
285     cell:&:@:screen-cell <- get *fake-screen, data:offset
286     11:@:screen-cell/raw <- copy *cell
287   ]
288   memory-should-contain [
289     10 <- 1  # cursor column
290     11 <- 4  # width*height
291     12 <- 97  # 'a'
292     13 <- 7  # white
293     14 <- 99  # 'c' over 'b'
294     15 <- 7  # white
295     # rest of screen is empty
296     16 <- 0
297   ]
298 ]
299 
300 scenario print-newline-character [
301   local-scope
302   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
303   a:char <- copy 97/a
304   fake-screen <- print fake-screen, a
305   run [
306     newline:char <- copy 10/newline
307     fake-screen <- print fake-screen, newline
308     10:num/raw <- get *fake-screen, cursor-row:offset
309     11:num/raw <- get *fake-screen, cursor-column:offset
310     cell:&:@:screen-cell <- get *fake-screen, data:offset
311     12:@:screen-cell/raw <- copy *cell
312   ]
313   memory-should-contain [
314     10 <- 1  # cursor row
315     11 <- 0  # cursor column
316     12 <- 6  # width*height
317     13 <- 97  # 'a'
318     14 <- 7  # white
319     # rest of screen is empty
320     15 <- 0
321   ]
322 ]
323 
324 scenario print-newline-at-bottom-line [
325   local-scope
326   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
327   newline:char <- copy 10/newline
328   fake-screen <- print fake-screen, newline
329   fake-screen <- print fake-screen, newline
330   run [
331     # cursor now at bottom of screen
332     fake-screen <- print fake-screen, newline
333     10:num/raw <- get *fake-screen, cursor-row:offset
334     11:num/raw <- get *fake-screen, cursor-column:offset
335   ]
336   # doesn't move further down
337   memory-should-contain [
338     10 <- 1  # cursor row
339     11 <- 0  # cursor column
340   ]
341 ]
342 
343 scenario print-character-at-bottom-right [
344   local-scope
345   fake-screen:&:screen <- new-fake-screen 2/width, 2/height
346   newline:char <- copy 10/newline
347   fake-screen <- print fake-screen, newline
348   a:char <- copy 97/a
349   fake-screen <- print fake-screen, a
350   b:char <- copy 98/b
351   fake-screen <- print fake-screen, b
352   c:char <- copy 99/c
353   fake-screen <- print fake-screen, c
354   fake-screen <- print fake-screen, newline
355   run [
356     # cursor now at bottom right
357     d:char <- copy 100/d
358     fake-screen <- print fake-screen, d
359     10:num/raw <- get *fake-screen, cursor-row:offset
360     11:num/raw <- get *fake-screen, cursor-column:offset
361     cell:&:@:screen-cell <- get *fake-screen, data:offset
362     20:@:screen-cell/raw <- copy *cell
363   ]
364   memory-should-contain [
365     10 <- 1  # cursor row
366     11 <- 1  # cursor column
367     20 <- 4  # width*height
368     21 <- 0  # unused
369     22 <- 7  # white
370     23 <- 0  # unused
371     24 <- 7  # white
372     25 <- 97 # 'a'
373     26 <- 7  # white
374     27 <- 100  # 'd' over 'b' and 'c' and newline
375     28 <- 7  # white
376     # rest of screen is empty
377     29 <- 0
378   ]
379 ]
380 
381 def clear-line screen:&:screen -> screen:&:screen [
382   local-scope
383   load-ingredients
384   space:char <- copy 0/nul
385   {
386     break-if screen
387     # real screen
388     clear-line-on-display
389     return
390   }
391   # fake screen
392   width:num <- get *screen, num-columns:offset
393   column:num <- get *screen, cursor-column:offset
394   original-column:num <- copy column
395   # space over the entire line
396   {
397     right:num <- subtract width, 1
398     done?:bool <- greater-or-equal column, right
399     break-if done?
400     print screen, space
401     column <- add column, 1
402     loop
403   }
404   # now back to where the cursor was
405   *screen <- put *screen, cursor-column:offset, original-column
406 ]
407 
408 def clear-line-until screen:&:screen, right:num/inclusive -> screen:&:screen [
409   local-scope
410   load-ingredients
411   _, column:num <- cursor-position screen
412   space:char <- copy 32/space
413   bg-color:num, bg-color-found?:bool <- next-ingredient
414   {
415     # default bg-color to black
416     break-if bg-color-found?
417     bg-color <- copy 0/black
418   }
419   {
420     done?:bool <- greater-than column, right
421     break-if done?
422     screen <- print screen, space, 7/white, bg-color  # foreground color is mostly unused except if the cursor shows up at this cell
423     column <- add column, 1
424     loop
425   }
426 ]
427 
428 def cursor-position screen:&:screen -> row:num, column:num [
429   local-scope
430   load-ingredients
431   {
432     break-if screen
433     # real screen
434     row, column <- cursor-position-on-display
435     return
436   }
437   # fake screen
438   row:num <- get *screen, cursor-row:offset
439   column:num <- get *screen, cursor-column:offset
440 ]
441 
442 def move-cursor screen:&:screen, new-row:num, new-column:num -> screen:&:screen [
443   local-scope
444   load-ingredients
445   {
446     break-if screen
447     # real screen
448     move-cursor-on-display new-row, new-column
449     return
450   }
451   # fake screen
452   *screen <- put *screen, cursor-row:offset, new-row
453   *screen <- put *screen, cursor-column:offset, new-column
454 ]
455 
456 scenario clear-line-erases-printed-characters [
457   local-scope
458   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
459   # print a character
460   a:char <- copy 97/a
461   fake-screen <- print fake-screen, a
462   # move cursor to start of line
463   fake-screen <- move-cursor fake-screen, 0/row, 0/column
464   run [
465     fake-screen <- clear-line fake-screen
466     cell:&:@:screen-cell <- get *fake-screen, data:offset
467     10:@:screen-cell/raw <- copy *cell
468   ]
469   # screen should be blank
470   memory-should-contain [
471     10 <- 6  # width*height
472     11 <- 0
473     12 <- 7
474     13 <- 0
475     14 <- 7
476     15 <- 0
477     16 <- 7
478     17 <- 0
479     18 <- 7
480     19 <- 0
481     20 <- 7
482     21 <- 0
483     22 <- 7
484   ]
485 ]
486 
487 def cursor-down screen:&:screen -> screen:&:screen [
488   local-scope
489   load-ingredients
490   {
491     break-if screen
492     # real screen
493     move-cursor-down-on-display
494     return
495   }
496   # fake screen
497   height:num <- get *screen, num-rows:offset
498   row:num <- get *screen, cursor-row:offset
499   max:num <- subtract height, 1
500   at-bottom?:bool <- greater-or-equal row, max
501   return-if at-bottom?
502   row <- add row, 1
503   *screen <- put *screen, cursor-row:offset, row
504 ]
505 
506 def cursor-up screen:&:screen -> screen:&:screen [
507   local-scope
508   load-ingredients
509   {
510     break-if screen
511     # real screen
512     move-cursor-up-on-display
513     return
514   }
515   # fake screen
516   row:num <- get *screen, cursor-row:offset
517   at-top?:bool <- lesser-or-equal row, 0
518   return-if at-top?
519   row <- subtract row, 1
520   *screen <- put *screen, cursor-row:offset, row
521 ]
522 
523 def cursor-right screen:&:screen -> screen:&:screen [
524   local-scope
525   load-ingredients
526   {
527     break-if screen
528     # real screen
529     move-cursor-right-on-display
530     return
531   }
532   # fake screen
533   width:num <- get *screen, num-columns:offset
534   column:num <- get *screen, cursor-column:offset
535   max:num <- subtract width, 1
536   at-bottom?:bool <- greater-or-equal column, max
537   return-if at-bottom?
538   column <- add column, 1
539   *screen <- put *screen, cursor-column:offset, column
540 ]
541 
542 def cursor-left screen:&:screen -> screen:&:screen [
543   local-scope
544   load-ingredients
545   {
546     break-if screen
547     # real screen
548     move-cursor-left-on-display
549     return
550   }
551   # fake screen
552   column:num <- get *screen, cursor-column:offset
553   at-top?:bool <- lesser-or-equal column, 0
554   return-if at-top?
555   column <- subtract column, 1
556   *screen <- put *screen, cursor-column:offset, column
557 ]
558 
559 def cursor-to-start-of-line screen:&:screen -> screen:&:screen [
560   local-scope
561   load-ingredients
562   row:num <- cursor-position screen
563   column:num <- copy 0
564   screen <- move-cursor screen, row, column
565 ]
566 
567 def cursor-to-next-line screen:&:screen -> screen:&:screen [
568   local-scope
569   load-ingredients
570   screen <- cursor-down screen
571   screen <- cursor-to-start-of-line screen
572 ]
573 
574 def move-cursor-to-column screen:&:screen, column:num -> screen:&:screen [
575   local-scope
576   load-ingredients
577   row:num, _ <- cursor-position screen
578   move-cursor screen, row, column
579 ]
580 
581 def screen-width screen:&:screen -> width:num [
582   local-scope
583   load-ingredients
584   {
585     break-unless screen
586     # fake screen
587     width <- get *screen, num-columns:offset
588     return
589   }
590   # real screen
591   width <- display-width
592 ]
593 
594 def screen-height screen:&:screen -> height:num [
595   local-scope
596   load-ingredients
597   {
598     break-unless screen
599     # fake screen
600     height <- get *screen, num-rows:offset
601     return
602   }
603   # real screen
604   height <- display-height
605 ]
606 
607 def hide-cursor screen:&:screen -> screen:&:screen [
608   local-scope
609   load-ingredients
610   return-if screen  # fake screen; do nothing
611   # real screen
612   hide-cursor-on-display
613 ]
614 
615 def show-cursor screen:&:screen -> screen:&:screen [
616   local-scope
617   load-ingredients
618   return-if screen  # fake screen; do nothing
619   # real screen
620   show-cursor-on-display
621 ]
622 
623 def hide-screen screen:&:screen -> screen:&:screen [
624   local-scope
625   load-ingredients
626   return-if screen  # fake screen; do nothing
627   # real screen
628   hide-display
629 ]
630 
631 def show-screen screen:&:screen -> screen:&:screen [
632   local-scope
633   load-ingredients
634   return-if screen  # fake screen; do nothing
635   # real screen
636   show-display
637 ]
638 
639 def print screen:&:screen, s:text -> screen:&:screen [
640   local-scope
641   load-ingredients
642   color:num, color-found?:bool <- next-ingredient
643   {
644     # default color to white
645     break-if color-found?
646     color <- copy 7/white
647   }
648   bg-color:num, bg-color-found?:bool <- next-ingredient
649   {
650     # default bg-color to black
651     break-if bg-color-found?
652     bg-color <- copy 0/black
653   }
654   len:num <- length *s
655   i:num <- copy 0
656   {
657     done?:bool <- greater-or-equal i, len
658     break-if done?
659     c:char <- index *s, i
660     print screen, c, color, bg-color
661     i <- add i, 1
662     loop
663   }
664 ]
665 
666 scenario print-text-stops-at-right-margin [
667   local-scope
668   fake-screen:&:screen <- new-fake-screen 3/width, 2/height
669   run [
670     fake-screen <- print fake-screen, [abcd]
671     cell:&:@:screen-cell <- get *fake-screen, data:offset
672     10:@:screen-cell/raw <- copy *cell
673   ]
674   memory-should-contain [
675     10 <- 6  # width*height
676     11 <- 97  # 'a'
677     12 <- 7  # white
678     13 <- 98  # 'b'
679     14 <- 7  # white
680     15 <- 100  # 'd' overwrites 'c'
681     16 <- 7  # white
682     # rest of screen is empty
683     17 <- 0
684   ]
685 ]
686 
687 def print screen:&:screen, n:num -> screen:&:screen [
688   local-scope
689   load-ingredients
690   color:num, color-found?:bool <- next-ingredient
691   {
692     # default color to white
693     break-if color-found?
694     color <- copy 7/white
695   }
696   bg-color:num, bg-color-found?:bool <- next-ingredient
697   {
698     # default bg-color to black
699     break-if bg-color-found?
700     bg-color <- copy 0/black
701   }
702   # todo: other bases besides decimal
703   s:text <- to-text n
704   screen <- print screen, s, color, bg-color
705 ]
706 
707 def print screen:&:screen, n:bool -> screen:&:screen [
708   local-scope
709   load-ingredients
710   color:num, color-found?:bool <- next-ingredient
711   {
712     # default color to white
713     break-if color-found?
714     color <- copy 7/white
715   }
716   bg-color:num, bg-color-found?:bool <- next-ingredient
717   {
718     # default bg-color to black
719     break-if bg-color-found?
720     bg-color <- copy 0/black
721   }
722   n2:num <- copy n
723   screen <- print screen, n2, color, bg-color
724 ]
725 
726 def print screen:&:screen, n:&:_elem -> screen:&:screen [
727   local-scope
728   load-ingredients
729   color:num, color-found?:bool <- next-ingredient
730   {
731     # default color to white
732     break-if color-found?
733     color <- copy 7/white
734   }
735   bg-color:num, bg-color-found?:bool <- next-ingredient
736   {
737     # default bg-color to black
738     break-if bg-color-found?
739     bg-color <- copy 0/black
740   }
741   n2:num <- copy n
742   screen <- print screen, n2, color, bg-color
743 ]