
\ -------------------------------------------------------------
\  Interface to real graphics hardware necessary.
\  This is just for ASCII art in terminal !
\ -------------------------------------------------------------

  : u.base10 ( u -- ) base @ decimal swap 0 <# #s #> type base ! ;
  : ESC[ ( -- ) 27 emit 91 emit ;
  : at-xy ( column row -- ) 1+ swap 1+ swap ESC[ u.base10 ." ;" u.base10 ." H" ;
  : page ESC[ ." 2J" 0 0 at-xy ;

: putpixel ( x y -- )  at-xy [char] * emit ;

\ -------------------------------------------------------------
\  Bresenham line
\ -------------------------------------------------------------

0 variable line-x1   0 variable line-y1
0 variable line-sx   0 variable line-sy
0 variable line-dx   0 variable line-dy
0 variable line-err

: line ( x0 y0 x1 y1 -- )

  line-y1 ! line-x1 !

  over line-x1 @ -   dup 0< if 1 else -1 then line-sx !   abs        line-dx !
  dup  line-y1 @ -   dup 0< if 1 else -1 then line-sy !   abs negate line-dy !
  line-dx @ line-dy @ + line-err !

  begin
    2dup putpixel
    2dup line-x1 @ line-y1 @ d<>
  while
    line-err @ 2* >r
    r@ line-dy @ > if line-dy @ line-err +! swap line-sx @ + swap then
    r> line-dx @ < if line-dx @ line-err +!      line-sy @ +      then
  repeat
  2drop
;

\ -------------------------------------------------------------
\  Bresenham ellipse
\ -------------------------------------------------------------

0 variable ellipse-xm   0 variable ellipse-ym
0 variable ellipse-dx   0 variable ellipse-dy
0 variable ellipse-a    0 variable ellipse-b
0 variable ellipse-a^2  0 variable ellipse-b^2
0 variable ellipse-err

: ellipse-putpixel ( y x -- ) ellipse-xm @ + swap ellipse-ym @ + putpixel ;

: ellipse-step ( -- )
    ellipse-dy @        ellipse-dx @        ellipse-putpixel
    ellipse-dy @ negate ellipse-dx @        ellipse-putpixel
    ellipse-dy @ negate ellipse-dx @ negate ellipse-putpixel
    ellipse-dy @        ellipse-dx @ negate ellipse-putpixel

    ellipse-err @ 2* >r
    r@  ellipse-dx @ 2* 1+ ellipse-b^2 @ *        < if  1 ellipse-dx +! ellipse-dx @ 2* 1+ ellipse-b^2 @ *        ellipse-err +! then
    r>  ellipse-dy @ 2* 1- ellipse-a^2 @ * negate > if -1 ellipse-dy +! ellipse-dy @ 2* 1- ellipse-a^2 @ * negate ellipse-err +! then
;


: ellipse ( xm ym a b -- )

  0 ellipse-dx ! dup ellipse-dy !

  dup ellipse-b ! dup * ellipse-b^2 !
  dup ellipse-a ! dup * ellipse-a^2 !
  ellipse-ym ! ellipse-xm !

  ellipse-b^2 @ ellipse-b @ 2* 1- ellipse-a^2 @ * - ellipse-err !

  begin
    ellipse-step
    ellipse-dy @ 0<
  until

  ellipse-dx @
  begin
    1+
    dup ellipse-a @ <
  while
    0 over        ellipse-putpixel
    0 over negate ellipse-putpixel
  repeat
  drop
;

: circle ( xm ym r -- ) dup ellipse ;


\ -------------------------------------------------------------
\ Artwork for 8x12 Bitmap Font, taken from Datapoint 8600
\ -------------------------------------------------------------

hex
create font

0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 32 Space
0800 h, 0808 h, 0808 h, 0008 h, 0808 h, 0000 h,   \ 33 !
1200 h, 1212 h, 0012 h, 0000 h, 0000 h, 0000 h,   \ 34 "
0000 h, 1212 h, 123F h, 3F12 h, 1212 h, 0000 h,   \ 35 #
0800 h, 493E h, 3E48 h, 4909 h, 083E h, 0000 h,   \ 36 $
2100 h, 2251 h, 0804 h, 2210 h, 4245 h, 0000 h,   \ 37 %
1800 h, 2424 h, 1028 h, 4629 h, 3B44 h, 0000 h,   \ 38 &
0200 h, 0C06 h, 1018 h, 0000 h, 0000 h, 0000 h,   \ 39 '
0E00 h, 2010 h, 2020 h, 2020 h, 0E10 h, 0000 h,   \ 40 (
3800 h, 0204 h, 0202 h, 0202 h, 3804 h, 0000 h,   \ 41 )
0000 h, 2A08 h, 7F1C h, 2A1C h, 0008 h, 0000 h,   \ 42 *
0000 h, 0808 h, 7F08 h, 0808 h, 0008 h, 0000 h,   \ 43 +
0000 h, 0000 h, 0000 h, 0C0C h, 0804 h, 0000 h,   \ 44 ,
0000 h, 0000 h, 0000 h, 007F h, 0000 h, 0000 h,   \ 45 -
0000 h, 0000 h, 0000 h, 0000 h, 0C0C h, 0000 h,   \ 46 .
0100 h, 0201 h, 0804 h, 2010 h, 4040 h, 0000 h,   \ 47 /

1E00 h, 2321 h, 2D27 h, 3139 h, 1E21 h, 0000 h,   \ 48 0
0800 h, 2818 h, 0808 h, 0808 h, 3E08 h, 0000 h,   \ 49 1
1E00 h, 2121 h, 0201 h, 0804 h, 3F10 h, 0000 h,   \ 50 2
1E00 h, 0121 h, 0E01 h, 0101 h, 1E21 h, 0000 h,   \ 51 3
0200 h, 0A06 h, 2212 h, 023F h, 0202 h, 0000 h,   \ 52 4
3F00 h, 2020 h, 1E20 h, 0101 h, 1E21 h, 0000 h,   \ 53 5
1E00 h, 2021 h, 3E20 h, 2121 h, 1E21 h, 0000 h,   \ 54 6
3F00 h, 0121 h, 0201 h, 0804 h, 0808 h, 0000 h,   \ 55 7
1E00 h, 2121 h, 1E21 h, 2121 h, 1E21 h, 0000 h,   \ 56 8
1E00 h, 2121 h, 1F21 h, 0101 h, 1E21 h, 0000 h,   \ 57 9

0000 h, 0C0C h, 0000 h, 0C0C h, 0000 h, 0000 h,   \ 58 :
0000 h, 0C0C h, 0000 h, 0C0C h, 0804 h, 0000 h,   \ 59 ;
0200 h, 0804 h, 2010 h, 0810 h, 0204 h, 0000 h,   \ 60 <
0000 h, 0000 h, 003F h, 3F00 h, 0000 h, 0000 h,   \ 61 =
2000 h, 0810 h, 0204 h, 0804 h, 2010 h, 0000 h,   \ 62 >
1E00 h, 2121 h, 0601 h, 0808 h, 0800 h, 0000 h,   \ 63 ?
3E00 h, 4741 h, 4949 h, 4047 h, 3F40 h, 0000 h,   \ 64 @

3E00 h, 4141 h, 7F41 h, 4141 h, 4141 h, 0000 h,   \ 65 A
7E00 h, 4141 h, 7E41 h, 4141 h, 7E41 h, 0000 h,   \ 66 B
3E00 h, 4041 h, 4040 h, 4040 h, 3E41 h, 0000 h,   \ 67 C
7C00 h, 4142 h, 4141 h, 4141 h, 7C42 h, 0000 h,   \ 68 D
7F00 h, 4040 h, 7E40 h, 4040 h, 7F40 h, 0000 h,   \ 69 E
7F00 h, 4040 h, 7E40 h, 4040 h, 4040 h, 0000 h,   \ 70 F
3E00 h, 4041 h, 4740 h, 4141 h, 3E41 h, 0000 h,   \ 71 G
4100 h, 4141 h, 7F41 h, 4141 h, 4141 h, 0000 h,   \ 72 H
3E00 h, 0808 h, 0808 h, 0808 h, 3E08 h, 0000 h,   \ 73 I
0700 h, 0202 h, 0202 h, 4202 h, 3C42 h, 0000 h,   \ 74 J
4100 h, 4442 h, 5048 h, 4468 h, 4142 h, 0000 h,   \ 75 K
4000 h, 4040 h, 4040 h, 4040 h, 7F40 h, 0000 h,   \ 76 L
4100 h, 5563 h, 4149 h, 4141 h, 4141 h, 0000 h,   \ 77 M
4100 h, 6161 h, 4951 h, 4345 h, 4143 h, 0000 h,   \ 78 N
1C00 h, 4122 h, 4141 h, 4141 h, 1C22 h, 0000 h,   \ 79 O
7E00 h, 4141 h, 7E41 h, 4040 h, 4040 h, 0000 h,   \ 80 P
3E00 h, 4141 h, 4141 h, 4545 h, 3D42 h, 0000 h,   \ 81 Q
7E00 h, 4141 h, 7E41 h, 4448 h, 4142 h, 0000 h,   \ 82 R
3E00 h, 4041 h, 3E40 h, 0101 h, 3E41 h, 0000 h,   \ 83 S
7F00 h, 0808 h, 0808 h, 0808 h, 0808 h, 0000 h,   \ 84 T
4100 h, 4141 h, 4141 h, 4141 h, 3E41 h, 0000 h,   \ 85 U
4100 h, 4141 h, 4141 h, 2241 h, 0814 h, 0000 h,   \ 86 V
4100 h, 4141 h, 4941 h, 5549 h, 4163 h, 0000 h,   \ 87 W
4100 h, 2241 h, 0814 h, 2214 h, 4141 h, 0000 h,   \ 88 X
4100 h, 2241 h, 0814 h, 0808 h, 0808 h, 0000 h,   \ 89 Y
7F00 h, 0201 h, 0804 h, 2010 h, 7F40 h, 0000 h,   \ 90 Z

3E00 h, 2020 h, 2020 h, 2020 h, 3E20 h, 0000 h,   \ 91 [
4000 h, 2040 h, 0810 h, 0204 h, 0101 h, 0000 h,   \ 92 \
3E00 h, 0202 h, 0202 h, 0202 h, 3E02 h, 0000 h,   \ 93 ]
0000 h, 0000 h, 0000 h, 1408 h, 4122 h, 0000 h,   \ 94 ^
0000 h, 0000 h, 0000 h, 0000 h, 7F00 h, 0000 h,   \ 95 _
1000 h, 0C18 h, 0206 h, 0000 h, 0000 h, 0000 h,   \ 96 `

\ No lowercase font data available from the ROM dump...

0E00 h, 1010 h, 2010 h, 1010 h, 0E10 h, 0000 h,   \ 123 {
0800 h, 0808 h, 0808 h, 0808 h, 0808 h, 0000 h,   \ 124 |
3800 h, 0404 h, 0204 h, 0404 h, 3804 h, 0000 h,   \ 125 }
0000 h, 0000 h, 3000 h, 0649 h, 0000 h, 0000 h,   \ 126 ~
0800 h, 0808 h, 6B49 h, 0849 h, 0808 h, 0000 h,   \ 127

\ Additional characters available in font data, but not used here:

\ 0000 h, 0200 h, 0E06 h, 3E1E h, FE7E h, 0000 h,   \ 1  Triangle
\ 0000 h, 0000 h, 0000 h, 0000 h, 000F h, 0000 h,   \ 2  Weird underscore
\ 0000 h, 1800 h, 7F20 h, 1820 h, 0000 h, 0000 h,   \ 8  Arrow left
\ 0000 h, 0C00 h, 7F02 h, 0C02 h, 0000 h, 0000 h,   \ 24 Arrow right

decimal

: ascii>bitpattern ( c -- c-addr ) \ Translates ASCII to address of bitpatterns.
  32 umax \ All control characters shall be space
  127 umin \ Display Glyph 127 for characters above 7-bit ASCII

  \ Handle hole in the data for lowercase letters
  \ as this is smaller than repeating the uppercase glyphs
  dup 96 u> if dup 123 u< if 32 - else 26 - then then

  32 - 12 * font +
1-foldable ;

\ -------------------------------------------------------------
\  Write a string with 8x12 bitmap font of Datapoint 8600
\ -------------------------------------------------------------

0 variable font-x   0 variable font-y

: drawbytepattern ( c -- )
  8 0 do dup 128 and if font-x @ font-y @ putpixel then shl 1 font-x +! loop
  drop -8 font-x +!
;

: drawcharacterbitmap ( c-addr -- )
  12 0 do dup c@ drawbytepattern 1 font-y +! 1+ loop
  drop -12 font-y +! 8 font-x +!
;

: get-first-char ( addr len -- addr   len c ) over c@ ;
: cut-first-char ( addr len -- addr+1 len-1 ) 1- swap 1+ swap ;

: drawstring ( addr u x y -- )
  font-y ! font-x !

  begin
    dup 0<>
  while \ Adjust the following code to add your own unicode characters.
    get-first-char ascii>bitpattern drawcharacterbitmap cut-first-char
  repeat
  2drop
;

\ -------------------------------------------------------------
\  A small demo
\ -------------------------------------------------------------

: demo ( -- )
  page
  50 24 32 10 ellipse
  50 24 34 12 ellipse
  s" Mecrisp" 22 19 drawstring
  2 14 12 34 line
  4 14 14 34 line
;
