
\ -----------------------------------------------------------------------------
\   Sharp display example for Happy Gecko
\ -----------------------------------------------------------------------------

\ A few necessary port registers first:

$40006000 $24 0 * + constant PA_Base
$40006000 $24 1 * + constant PB_Base
$40006000 $24 2 * + constant PC_Base
$40006000 $24 3 * + constant PD_Base
$40006000 $24 4 * + constant PE_Base
$40006000 $24 5 * + constant PF_Base

PA_Base $08 +  constant  PA_MODEH        \ RW  Port Pin Mode High Register
PA_Base $10 +  constant  PA_DOUTSET      \ W1  Port Data Out Set Register
PA_Base $14 +  constant  PA_DOUTCLR      \ W1  Port Data Out Clear Register

PE_Base $08 +  constant  PE_MODEH        \ RW  Port Pin Mode High Register
PE_Base $10 +  constant  PE_DOUTSET      \ W1  Port Data Out Set Register
PE_Base $14 +  constant  PE_DOUTCLR      \ W1  Port Data Out Clear Register

PF_Base $04 +  constant  PF_MODEL        \ RW  Port Pin Mode Low Register
PF_Base $18 +  constant  PF_DOUTTGL      \ W1  Port Data Out Toggle Register

\ -----------------------------------------------------------------------------
\   Connections:
\ -----------------------------------------------------------------------------

\ PA8  : EFM_DISP_ENABLE

\ PE12 : EFM_DISP_SCLK
\ PE10 : EFM_DISP_MOSI
\ PA10 : EFM_DISP_CS
\ PF3  : EFM_DISP_COM

: lcd-clk-high  ( -- ) 1 12 lshift PE_DOUTSET !  inline ;
: lcd-clk-low   ( -- ) 1 12 lshift PE_DOUTCLR !  inline ;

: lcd-data-high ( -- ) 1 10 lshift PE_DOUTSET !  inline ;
: lcd-data-low  ( -- ) 1 10 lshift PE_DOUTCLR !  inline ;

: lcd-select    ( -- ) 1 10 lshift PA_DOUTSET !  inline ;
: lcd-deselect  ( -- ) 1 10 lshift PA_DOUTCLR !  inline ;

: lcd-togglecom ( -- ) 1  3 lshift PF_DOUTTGL !  inline ;

\ -----------------------------------------------------------------------------
\   Low-Level driver implementation
\ -----------------------------------------------------------------------------

128 constant resolution

: lcd-bit ( ? -- ) if lcd-data-high else lcd-data-low then
                  nop lcd-clk-high  nop  lcd-clk-low ;

: >lcd ( c -- )
  dup   1 and lcd-bit
  dup   2 and lcd-bit
  dup   4 and lcd-bit
  dup   8 and lcd-bit
  dup  16 and lcd-bit
  dup  32 and lcd-bit
  dup  64 and lcd-bit
      128 and lcd-bit
;

: lcd-clear ( -- )
  lcd-select
  4 >lcd
  0 >lcd
  lcd-deselect
;

: lcd-image ( addr -- )
  lcd-select
  1 >lcd ( Command to write a line )

  resolution 1+ 1 do
    i >lcd \ Line number
    resolution 8 / 0 do
      dup c@ >lcd
      1+
    loop
    0 >lcd \ Trailer
  loop
  drop
  0 >lcd \ Finished
  lcd-deselect
;

: init-lcd ( -- )

\ PA8  : EFM_DISP_ENABLE
\ PA10 : EFM_DISP_CS

\ PE12 : EFM_DISP_SCLK
\ PE10 : EFM_DISP_MOSI

\ PF3  : EFM_DISP_COM

  1 8 lshift pa_doutset ! \ Enable display interface on Happy Gecko hardware
  lcd-deselect
  lcd-clk-low

   $404 pa_modeh bis! \ Set PA8  and PA10 as Push-Pull-Output
 $40400 pe_modeh bis! \ Set PE10 and PE12 as Push-Pull-Output
  $4000 pf_model bis! \ Set PF3 as Push-Pull-Output

  lcd-clear

  \ Frame frequency needs to be between 1 and 60 Hz.
  ['] lcd-togglecom irq-systick !

  1400000 $E000E014 ! \ How many ticks between interrupts ? 10 Hz with 14 MHz clock.
        7 $E000E010 ! \ Enable the systick interrupt.

  eint
;

\ -----------------------------------------------------------------------------
\   Time for Pixels !
\ -----------------------------------------------------------------------------

resolution 8 /  resolution * buffer: image

: refresh ( -- ) image lcd-image ;                            \ Update graphics
: clrbuf  ( -- ) image resolution 8 /  resolution * 255 fill ; \ Clear buffer
: clrscr  ( -- ) clrbuf lcd-clear ;                             \ Clear screen

: pixeladdr ( x y -- pattern c-addr ) \ X and Y from 0 to resolution-1, no checks
  resolution 8 / * image + ( x y-addr )
  swap ( y-addr x )
  dup shr shr shr ( y-addr x x-addr )
  >r ( y-addr x  R: x-addr )
  1 swap 7 and lshift ( y-addr pattern R: x-addr )
  swap r> +
2-foldable ;

: setpixel ( x y -- ) pixeladdr cbic! ;
: clrpixel ( x y -- ) pixeladdr cbis! ;
: xorpixel ( x y -- ) pixeladdr cxor! ;

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

: crosshair ( -- )
  init-lcd
  clrscr

  resolution 0 do \ Draw a border
               2  i              setpixel
  resolution 3 -  i              setpixel
               i  2              setpixel
               i  resolution 3 - setpixel
  loop


  resolution 2/ 6 + resolution 2/ 6 - do \ Draw crosshair
    i resolution 2/ setpixel
    resolution 2/ i setpixel
  loop

  refresh
;

\ -------------------------------------------------------------
\  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 setpixel
    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-setpixel ( y x -- ) ellipse-xm @ + swap ellipse-ym @ + setpixel ;

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

    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-setpixel
    0 over negate ellipse-setpixel
  repeat
  drop
;

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


\ -------------------------------------------------------------
\ Artwork for 8x8 Bitmap Font, taken mostly from Commodore C64
\ -------------------------------------------------------------

hex
create font

0000 h, 0000 h, 0000 h, 0000 h,  \ 32: Space
1818 h, 1818 h, 0000 h, 0018 h,  \ 33 !
6666 h, 0066 h, 0000 h, 0000 h,  \ 34 "
6666 h, 66FF h, 66FF h, 0066 h,  \ 35 #
3E18 h, 3C60 h, 7C06 h, 0018 h,  \ 36 $
6662 h, 180C h, 6630 h, 0046 h,  \ 37 %
663C h, 383C h, 6667 h, 003F h,  \ 38 &
1818 h, 0018 h, 0000 h, 0000 h,  \ 39 '  (*)
180C h, 3030 h, 1830 h, 000C h,  \ 40 (
1830 h, 0C0C h, 180C h, 0030 h,  \ 41 )
6600 h, FF3C h, 663C h, 0000 h,  \ 42 *
1800 h, 7E18 h, 1818 h, 0000 h,  \ 43 +
0000 h, 0000 h, 1800 h, 3018 h,  \ 44 ,
0000 h, 7E00 h, 0000 h, 0000 h,  \ 45 -
0000 h, 0000 h, 1800 h, 0018 h,  \ 46 .
0300 h, 0C06 h, 3018 h, 0060 h,  \ 47 /
663C h, 766E h, 6666 h, 003C h,  \ 48 0
1818 h, 1838 h, 1818 h, 007E h,  \ 49 1
663C h, 0C06 h, 6030 h, 007E h,  \ 50 2
663C h, 1C06 h, 6606 h, 003C h,  \ 51 3
0E06 h, 661E h, 067F h, 0006 h,  \ 52 4
607E h, 067C h, 6606 h, 003C h,  \ 53 5
663C h, 7C60 h, 6666 h, 003C h,  \ 54 6
667E h, 180C h, 1818 h, 0018 h,  \ 55 7
663C h, 3C66 h, 6666 h, 003C h,  \ 56 8
663C h, 3E66 h, 6606 h, 003C h,  \ 57 9
0000 h, 0018 h, 1800 h, 0000 h,  \ 58 :
0000 h, 0018 h, 1800 h, 3018 h,  \ 59 ;
180E h, 6030 h, 1830 h, 000E h,  \ 60 <
0000 h, 007E h, 007E h, 0000 h,  \ 61 =
1870 h, 060C h, 180C h, 0070 h,  \ 62 >
663C h, 0C06 h, 0018 h, 0018 h,  \ 63 ?

663C h, 6E6E h, 6260 h, 003C h,  \ 64 @
3C18 h, 7E66 h, 6666 h, 0066 h,  \ 65 A
667C h, 7C66 h, 6666 h, 007C h,  \ 66 B
663C h, 6060 h, 6660 h, 003C h,  \ 67 C
6C78 h, 6666 h, 6C66 h, 0078 h,  \ 68 D
607E h, 7860 h, 6060 h, 007E h,  \ 69 E
607E h, 7860 h, 6060 h, 0060 h,  \ 70 F
663C h, 6E60 h, 6666 h, 003C h,  \ 71 G
6666 h, 7E66 h, 6666 h, 0066 h,  \ 72 H
183C h, 1818 h, 1818 h, 003C h,  \ 73 I
0C1E h, 0C0C h, 6C0C h, 0038 h,  \ 74 J
6C66 h, 7078 h, 6C78 h, 0066 h,  \ 75 K
6060 h, 6060 h, 6060 h, 007E h,  \ 76 L
7763 h, 6B7F h, 6363 h, 0063 h,  \ 77 M
7666 h, 7E7E h, 666E h, 0066 h,  \ 78 N
663C h, 6666 h, 6666 h, 003C h,  \ 79 O
667C h, 7C66 h, 6060 h, 0060 h,  \ 80 P
663C h, 6666 h, 3C66 h, 000E h,  \ 81 Q
667C h, 7C66 h, 6C78 h, 0066 h,  \ 82 R
663C h, 3C60 h, 6606 h, 003C h,  \ 83 S
187E h, 1818 h, 1818 h, 0018 h,  \ 84 T
6666 h, 6666 h, 6666 h, 003C h,  \ 85 U
6666 h, 6666 h, 3C66 h, 0018 h,  \ 86 V
6363 h, 6B63 h, 777F h, 0063 h,  \ 87 W
6666 h, 183C h, 663C h, 0066 h,  \ 88 X
6666 h, 3C66 h, 1818 h, 0018 h,  \ 89 Y
067E h, 180C h, 6030 h, 007E h,  \ 90 Z
303C h, 3030 h, 3030 h, 003C h,  \ 91 [
6000 h, 1830 h, 060C h, 0003 h,  \ 92 \  (*)
0C3C h, 0C0C h, 0C0C h, 003C h,  \ 93 ]
1C08 h, 0063 h, 0000 h, 0000 h,  \ 94 ^  (*)
0000 h, 0000 h, 0000 h, 00FF h,  \ 95 _

1818 h, 000C h, 0000 h, 0000 h,  \ 96  ` (*)
0000 h, 063C h, 663E h, 003E h,  \ 97  a
6000 h, 7C60 h, 6666 h, 007C h,  \ 98  b
0000 h, 603C h, 6060 h, 003C h,  \ 99  c
0600 h, 3E06 h, 6666 h, 003E h,  \ 100 d
0000 h, 663C h, 607E h, 003C h,  \ 101 e
0E00 h, 3E18 h, 1818 h, 0018 h,  \ 102 f
0000 h, 663E h, 3E66 h, 7C06 h,  \ 103 g
6000 h, 7C60 h, 6666 h, 0066 h,  \ 104 h
1800 h, 3800 h, 1818 h, 003C h,  \ 105 i
0600 h, 0600 h, 0606 h, 3C06 h,  \ 106 j
6000 h, 6C60 h, 6C78 h, 0066 h,  \ 107 k
3800 h, 1818 h, 1818 h, 003C h,  \ 108 l
0000 h, 7F66 h, 6B7F h, 0063 h,  \ 109 m
0000 h, 667C h, 6666 h, 0066 h,  \ 110 n
0000 h, 663C h, 6666 h, 003C h,  \ 111 o
0000 h, 667C h, 7C66 h, 6060 h,  \ 112 p
0000 h, 663E h, 3E66 h, 0606 h,  \ 113 q
0000 h, 667C h, 6060 h, 0060 h,  \ 114 r
0000 h, 603E h, 063C h, 007C h,  \ 115 s
1800 h, 187E h, 1818 h, 000E h,  \ 116 t
0000 h, 6666 h, 6666 h, 003E h,  \ 117 u
0000 h, 6666 h, 3C66 h, 0018 h,  \ 118 v
0000 h, 6B63 h, 3E7F h, 0036 h,  \ 119 w
0000 h, 3C66 h, 3C18 h, 0066 h,  \ 120 x
0000 h, 6666 h, 3E66 h, 780C h,  \ 121 y
0000 h, 0C7E h, 3018 h, 007E h,  \ 122 z
180E h, 7018 h, 1818 h, 000E h,  \ 123 {  (*)
1818 h, 1818 h, 1818 h, 1818 h,  \ 124 |  (*)
1870 h, 0E18 h, 1818 h, 0070 h,  \ 125 }  (*)
0000 h, 6E3B h, 0000 h, 0000 h,  \ 126 ~  (*)
FFFF h, FFFF h, FFFF h, FFFF h,  \ 127 DEL

decimal

: ascii>bitpattern ( c -- c-addr ) \ Translates ASCII to address of bitpatterns.
  32 umax 127 umin
  32 - 8 * font +
1-foldable ;

\ -------------------------------------------------------------
\  Write a string with 8x8 bitmap font of the Commodore 64
\ -------------------------------------------------------------

0 variable font-x   0 variable font-y

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

: drawcharacterbitmap ( c-addr -- )
  8 0 do dup c@ drawbytepattern 1 font-y +! 1+ loop
  drop -8 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 of everything
\ -------------------------------------------------------------

: mecrisp ( -- )
  init-lcd
  clrscr
  50 24 32 10 ellipse
  50 24 34 12 ellipse
  s" Mecrisp" 22 20 drawstring
  2 14 12 34 line
  4 14 14 34 line
  refresh
;


