
\ Partial ARM Cortex M3/M4 Disassembler, Copyright (C) 2013  Matthias Koch
\ This is free software under GNU General Public License v3.
\ Knows all M0 and some M3/M4 machine instructions,
\ resolves call entry points, literal pools and handles inline strings.
\ Usage: Specify your target address in disasm-$ and give disasm-step some calls.

\ ------------------------
\  A quick list of words
\ ------------------------

: list ( -- )
  cr
  dictionarystart
  begin
    dup 6 + ctype space
    dictionarynext
  until
  drop
;

\ ---------------------------------------
\  Memory pointer and instruction fetch
\ ---------------------------------------

0 variable disasm-$   \ Current position for disassembling

: disasm-fetch        \ ( -- Data ) Fetches opcodes and operands, increments disasm-$
    disasm-$ @ h@     \             Holt Opcode oder Operand, incrementiert disasm-$
  2 disasm-$ +!   ;

\ --------------------------------------------------
\  Try to find address as code start in Dictionary
\ --------------------------------------------------

: disasm-string ( -- ) \ Takes care of an inline string
  disasm-$ @ dup ctype skipstring disasm-$ !
;

: name. ( Address -- ) \ If the address is Code-Start of a dictionary word, it gets named.
  1 bic \ Thumb has LSB of address set.

  >r
  dictionarystart
  begin
    dup   6 + dup skipstring r@ = if ."   --> " ctype else drop then
    dictionarynext
  until
  drop
  r>

  case \ Check for inline strings ! They are introduced by calls to ." or s" internals.
    ['] ." $1E + of ."   -->  .' " disasm-string ." '" endof \ It is ." runtime ?
    ['] s"  $4 + of ."   -->  s' " disasm-string ." '" endof \ It is .s runtime ?
    ['] c"  $4 + of ."   -->  c' " disasm-string ." '" endof \ It is .c runtime ?
  endcase
;

\ -------------------
\  Beautiful output
\ -------------------

: u.4  0 <# # # # # #> type ;
: u.8  0 <# # # # # # # # # #> type ;
: u.ns 0 <# #s #> type ;
: const. ."  #" u.ns ;
: addr. u.8 ;

: register. ( u -- )
  case
    13 of ."  sp" endof
    14 of ."  lr" endof
    15 of ."  pc" endof
    dup ."  r" decimal u.ns hex
  endcase ;

\ ----------------------------------------
\  Disassembler logic and opcode cutters
\ ----------------------------------------

: opcode? ( Opcode Bits Mask -- Opcode ? ) \ (Opcode and Mask) = Bits
  rot ( Bits Mask Opcode )
  tuck ( Bits Opcode Mask Opcode )
  and ( Bits Opcode Opcode* )
  rot ( Opcode Opcode* Bits )
  =
;

: reg.    ( Opcode Position -- Opcode ) over swap rshift  $7 and register. ;
: reg16.  ( Opcode Position -- Opcode ) over swap rshift  $F and register. ;
: reg16split. ( Opcode -- Opcode ) dup $0007 and over 4 rshift $0008 and or register. ;
: registerlist. ( Opcode -- Opcode ) 8 0 do dup 1 i lshift and if i register. space then loop ;

: imm3. ( Opcode Position -- Opcode ) over swap rshift  $7  and const. ;
: imm5. ( Opcode Position -- Opcode ) over swap rshift  $1F and const. ;
: imm8. ( Opcode Position -- Opcode ) over swap rshift  $FF and const. ;

: imm3<<1. ( Opcode Position -- Opcode ) over swap rshift  $7  and shl const. ;
: imm5<<1. ( Opcode Position -- Opcode ) over swap rshift  $1F and shl const. ;
: imm8<<1. ( Opcode Position -- Opcode ) over swap rshift  $FF and shl const. ;

: imm3<<2. ( Opcode Position -- Opcode ) over swap rshift  $7  and shl shl const. ;
: imm5<<2. ( Opcode Position -- Opcode ) over swap rshift  $1F and shl shl const. ;
: imm7<<2. ( Opcode Position -- Opcode ) over swap rshift  $7F and shl shl const. ;
: imm8<<2. ( Opcode Position -- Opcode ) over swap rshift  $FF and shl shl const. ;

: condition. ( Condition -- )
  case
    $0 of ." eq" endof  \ Z set
    $1 of ." ne" endof  \ Z clear
    $2 of ." cs" endof  \ C set
    $3 of ." cc" endof  \ C clear

    $4 of ." mi" endof  \ N set
    $5 of ." pl" endof  \ N clear
    $6 of ." vs" endof  \ V set
    $7 of ." vc" endof  \ V clear

    $8 of ." hi" endof  \ C set Z clear
    $9 of ." ls" endof  \ C clear or Z set
    $A of ." ge" endof  \ N == V
    $B of ." lt" endof  \ N != V

    $C of ." gt" endof  \ Z==0 and N == V
    $D of ." le" endof  \ Z==1 or N != V
  endcase
;

: imm12. ( Opcode -- Opcode )
  dup $FF and                 \ Bits 0-7
  over  4 rshift $700 and or  \ Bits 8-10
  over 15 rshift $800 and or  \ Bit  11
  ( Opcode imm12 )
  dup 8 rshift
  case
    0 of $FF and                                  const. endof \ Plain 8 Bit Constant
    1 of $FF and                 dup 16 lshift or const. endof \ 0x00XY00XY
    2 of $FF and        8 lshift dup 16 lshift or const. endof \ 0xXY00XY00
    3 of $FF and dup 8 lshift or dup 16 lshift or const. endof \ 0xXYXYXYXY

    \ Shifted 8-Bit Constant
    swap
      \ Otherwise, the 32-bit constant is rotated left until the most significant bit is bit[7]. The size of the left
      \ rotation is encoded in bits[11:7], overwriting bit[7]. imm12 is bits[11:0] of the result.
      dup 7 rshift swap $7F and $80 or swap rrotate const.
  endcase
;

\ --------------------------------------
\  Name resolving for blx r0 sequences
\ --------------------------------------

0 variable destination-r0

\ ----------------------------------
\  Single instruction disassembler
\ ----------------------------------

: disasm-thumb-2 ( Opcode16 -- Opcode16 )
  dup 16 lshift disasm-fetch or ( Opcode16 Opcode32 )

  $F000D000 $F800D000 opcode? if  \ BL
                                ( Opcode )
                                ." bl  "
                                dup $7FF and ( Opcode DestinationL )
                                over ( Opcode DestinationL Opcode )
                                16 rshift $7FF and ( Opcode DestinationL DestinationH )
                                dup $400 and if $FFFFF800 or then ( Opcode DestinationL DestinationHsigned )
                                11 lshift or ( Opcode Destination )
                                shl
                                disasm-$ @ +
                                dup addr. name. \ Try to resolve destination
                              then

  \ MOVW / MOVT
  \ 1111 0x10 t100 xxxx 0xxx dddd xxxx xxxx
  \ F    2    4    0    0    0    0    0
  \ F    B    7    0    8    0    0    0

  $F2400000 $FB708000 opcode? if \ MOVW / MOVT
                                ( Opcode )
                                dup $00800000 and if ." movt"
                                                  else ." movw"
                                                  then

                                8 reg16. \ Destination register

                                \ Extract 16 Bit constant from opcode:
                                dup        $FF and              ( Opcode Constant* )
                                over     $7000 and  4 rshift or ( Opcode Constant** )
                                over $04000000 and 15 rshift or ( Opcode Constant*** )
                                over $000F0000 and  4 rshift or ( Opcode Constant )
                                dup ."  #" u.4
                                ( Opcode Constant )
                                over $00800000 and if 16 lshift destination-r0 @ or destination-r0 !
                                                   else                             destination-r0 !
                                                   then
                              then

  \
  \ 1111 0i0x xxxs nnnn 0iii dddd iiii iiii
  \ F    0    0    0    0    0    0    0
  \ F    A    0    0    8    0    0    0

  $F0000000 $FA008000 opcode? not if else \ Data processing, modified 12-bit immediate
                                dup 21 rshift $F and
                                case
                                  %0000 of ." and" endof
                                  %0001 of ." bic" endof
                                  %0010 of ." orr" endof
                                  %0011 of ." orn" endof
                                  %0100 of ." eor" endof
                                  %1000 of ." add" endof
                                  %1010 of ." adc" endof
                                  %1011 of ." sbc" endof
                                  %1101 of ." sub" endof
                                  %1110 of ." rsb" endof
                                  ." ?"
                                endcase
                                dup 1 20 lshift and if ." s" then \ Set Flags ?
                                8 reg16. 16 reg16. \ Destionation and Source registers
                                imm12.
                              then

  case \ Decode remaining "singular" opcodes used in Mecrisp-Stellaris:

    $F8470D04 of ." str r0 [ r7 #-4 ]!" endof
    $F8471D04 of ." str r1 [ r7 #-4 ]!" endof
    $F8472D04 of ." str r2 [ r7 #-4 ]!" endof
    $F8473D04 of ." str r3 [ r7 #-4 ]!" endof
    $F8476D04 of ." str r6 [ r7 #-4 ]!" endof

    $F8576026 of ." ldr r6 [ r7 r6 lsl #2 ]" endof
    $F85D6C08 of ." ldr r6 [ sp #-8 ]" endof

    $FAB6F686 of ." clz r6 r6" endof

    $FB90F6F6 of ." sdiv r6 r0 r6" endof
    $FBB0F6F6 of ." udiv r6 r0 r6" endof
    $FBA00606 of ." umull r0 r6 r0 r6" endof
    $FBA00806 of ." smull r0 r6 r0 r6" endof

  endcase \ Case drops Opcode32
  ( Opcode16 )
;

: disasm ( -- ) \ Disassembles one machine instruction and advances disasm-$

disasm-fetch \ Instruction opcode on stack the whole time.

$4140 $FFC0 opcode? if ." adcs"  0 reg. 3 reg. then          \ ADC
$1C00 $FE00 opcode? if ." adds" 0 reg. 3 reg. 6 imm3. then   \ ADD(1) small immediate two registers
$3000 $F800 opcode? if ." adds" 8 reg. 0 imm8. then          \ ADD(2) big immediate one register
$1800 $FE00 opcode? if ." adds" 0 reg. 3 reg. 6 reg. then    \ ADD(3) three registers
$4400 $FF00 opcode? if ." add"  reg16split. 3 reg16. then    \ ADD(4) two registers one or both high no flags
$A000 $F800 opcode? if ." add"  8 reg. ."  pc " 0 imm8<<2. then  \ ADD(5) rd = pc plus immediate
$A800 $F800 opcode? if ." add"  8 reg. ."  sp " 0 imm8<<2. then  \ ADD(6) rd = sp plus immediate
$B000 $FF80 opcode? if ." add sp" 0 imm7<<2. then            \ ADD(7) sp plus immediate

$4000 $FFC0 opcode? if ." ands" 0 reg. 3 reg. then           \ AND
$1000 $F800 opcode? if ." asrs" 0 reg. 3 reg. 6 imm5. then   \ ASR(1) two register immediate
$4100 $FFC0 opcode? if ." asrs" 0 reg. 3 reg. then           \ ASR(2) two register
$D000 $F000 opcode? not if else dup $0F00 and 8 rshift       \ B(1) conditional branch
                       case
                         $00 of ." beq" endof  \ Z set
                         $01 of ." bne" endof  \ Z clear
                         $02 of ." bcs" endof  \ C set
                         $03 of ." bcc" endof  \ C clear

                         $04 of ." bmi" endof  \ N set
                         $05 of ." bpl" endof  \ N clear
                         $06 of ." bvs" endof  \ V set
                         $07 of ." bvc" endof  \ V clear

                         $08 of ." bhi" endof  \ C set Z clear
                         $09 of ." bls" endof  \ C clear or Z set
                         $0A of ." bge" endof  \ N == V
                         $0B of ." blt" endof  \ N != V

                         $0C of ." bgt" endof  \ Z==0 and N == V
                         $0D of ." ble" endof  \ Z==1 or N != V
                         \ $0E: Undefined Instruction
                         $0F of ." swi"  0 imm8.   drop exit endof
                       endcase
                       space
                       dup $FF and dup $80 and if $FFFFFF00 or then
                       shl disasm-$ @ 1 bic + 2 + addr.
                    then

$E000 $F800 opcode? if ." b"                                 \ B(2) unconditional branch
                      dup $7FF and shl
                      dup $800 and if $FFFFF000 or then
                      disasm-$ @ + 2+
                      space addr.
                    then

$4380 $FFC0 opcode? if ." bics" 0 reg. 3 reg. then           \ BIC
$BE00 $FF00 opcode? if ." bkpt" 0 imm8. then                 \ BKPT

\ BL/BLX handled as Thumb-2 instruction on M3/M4.

$4780 $FF87 opcode? if ." blx"  3 reg16. then                \ BLX(2)
$4700 $FF87 opcode? if ." bx"   3 reg16. then                \ BX
$42C0 $FFC0 opcode? if ." cmns" 0 reg. 3 reg. then           \ CMN
$2800 $F800 opcode? if ." cmp"  8 reg. 0 imm8. then          \ CMP(1) compare immediate
$4280 $FFC0 opcode? if ." cmp"  0 reg. 3 reg. then           \ CMP(2) compare register
$4500 $FF00 opcode? if ." cmp"  reg16split. 3 reg16. then    \ CMP(3) compare high register
$B660 $FFE8 opcode? if ." cps"  0 imm5. then                 \ CPS
$4040 $FFC0 opcode? if ." eors" 0 reg. 3 reg. then           \ EOR

$C800 $F800 opcode? if ." ldmia" 8 reg. ."  {" registerlist. ." }" then     \ LDMIA

$6800 $F800 opcode? if ." ldr" 0 reg. ."  [" 3 reg. 6 imm5<<2. ."  ]" then  \ LDR(1) two register immediate
$5800 $FE00 opcode? if ." ldr" 0 reg. ."  [" 3 reg. 6 reg. ."  ]" then      \ LDR(2) three register
$4800 $F800 opcode? if ." ldr" 8 reg. ."  [ pc" 0 imm8<<2. ."  ]  Literal " \ LDR(3) literal pool
                       dup $FF and shl shl ( Opcode Offset ) \ Offset for PC
                       disasm-$ @ 2+ 3 bic + ( Opcode Address )
                       dup addr. ." : " @ addr. then

$9800 $F800 opcode? if ." ldr"  8 reg. ."  [ sp" 0 imm8<<2. ."  ]" then     \ LDR(4)

$7800 $F800 opcode? if ." ldrb" 0 reg. ."  [" 3 reg. 6 imm5. ."  ]" then    \ LDRB(1) two register immediate
$5C00 $FE00 opcode? if ." ldrb" 0 reg. ."  [" 3 reg. 6 reg.  ."  ]" then    \ LDRB(2) three register

$8800 $F800 opcode? if ." ldrh" 0 reg. ."  [" 3 reg. 6 imm5<<1. ."  ]" then \ LDRH(1) two register immediate
$5A00 $FE00 opcode? if ." ldrh" 0 reg. ."  [" 3 reg. 6 reg.  ."  ]" then    \ LDRH(2) three register

$5600 $FE00 opcode? if ." ldrsb" 0 reg. ."  [" 3 reg. 6 reg. ."  ]" then    \ LDRSB
$5E00 $FE00 opcode? if ." ldrsh" 0 reg. ."  [" 3 reg. 6 reg. ."  ]" then    \ LDRSH

$0000 $F800 opcode? if ." lsls" 0 reg. 3 reg. 6 imm5. then   \ LSL(1)
$4080 $FFC0 opcode? if ." lsls" 0 reg. 3 reg. then           \ LSL(2) two register
$0800 $F800 opcode? if ." lsrs" 0 reg. 3 reg. 6 imm5. then   \ LSR(1) two register immediate
$40C0 $FFC0 opcode? if ." lsrs" 0 reg. 3 reg. then           \ LSR(2) two register
$2000 $F800 opcode? if ." movs" 8 reg. 0 imm8. then          \ MOV(1) immediate
$4600 $FF00 opcode? if ." mov" reg16split. 3 reg16. then     \ MOV(3)

$4340 $FFC0 opcode? if ." muls" 0 reg. 3 reg. then           \ MUL
$43C0 $FFC0 opcode? if ." mvns" 0 reg. 3 reg. then           \ MVN
$4240 $FFC0 opcode? if ." negs" 0 reg. 3 reg. then           \ NEG
$4300 $FFC0 opcode? if ." orrs" 0 reg. 3 reg. then           \ ORR

$BC00 $FE00 opcode? if ." pop {"  registerlist. dup $0100 and if ."  pc " then ." }" then \ POP
$B400 $FE00 opcode? if ." push {" registerlist. dup $0100 and if ."  lr " then ." }" then \ PUSH

$BA00 $FFC0 opcode? if ." rev"   0 reg. 3 reg. then         \ REV
$BA40 $FFC0 opcode? if ." rev16" 0 reg. 3 reg. then         \ REV16
$BAC0 $FFC0 opcode? if ." revsh" 0 reg. 3 reg. then         \ REVSH
$41C0 $FFC0 opcode? if ." rors"  0 reg. 3 reg. then         \ ROR
$4180 $FFC0 opcode? if ." sbcs"  0 reg. 3 reg. then         \ SBC

$C000 $F800 opcode? if ." stmia" 8 reg. ."  {" registerlist. ." }" then     \ STMIA

$6000 $F800 opcode? if ." str" 0 reg. ."  [" 3 reg. 6 imm5<<2. ."  ]" then  \ STR(1) two register immediate
$5000 $FE00 opcode? if ." str" 0 reg. ."  [" 3 reg. 6 reg. ."  ]" then      \ STR(2) three register
$9000 $F800 opcode? if ." str" 8 reg. ."  [ sp + " 0 imm8<<2. ."  ]" then   \ STR(3)

$7000 $F800 opcode? if ." strb" 0 reg. ."  [" 3 reg. 6 imm5. ."  ]" then    \ STRB(1) two register immediate
$5400 $FE00 opcode? if ." strb" 0 reg. ."  [" 3 reg. 6 reg.  ."  ]" then    \ STRB(2) three register

$8000 $F800 opcode? if ." strh" 0 reg. ."  [" 3 reg. 6 imm5<<1. ."  ]" then \ STRH(1) two register immediate
$5200 $FE00 opcode? if ." strh" 0 reg. ."  [" 3 reg. 6 reg.  ."  ]" then    \ STRH(2) three register

$1E00 $FE00 opcode? if ." subs" 0 reg. 3 reg. 6 imm3. then   \ SUB(1)
$3800 $F800 opcode? if ." subs" 8 reg. 0 imm8. then          \ SUB(2)
$1A00 $FE00 opcode? if ." subs" 0 reg. 3 reg. 6 reg. then    \ SUB(3)
$B080 $FF80 opcode? if ." sub sp" 0 imm7<<2. then            \ SUB(4)

$B240 $FFC0 opcode? if ." sxtb" 0 reg. 3 reg. then           \ SXTB
$B200 $FFC0 opcode? if ." sxth" 0 reg. 3 reg. then           \ SXTH
$4200 $FFC0 opcode? if ." tst"  0 reg. 3 reg. then           \ TST
$B2C0 $FFC0 opcode? if ." uxtb" 0 reg. 3 reg. then           \ UXTB
$B280 $FFC0 opcode? if ." uxth" 0 reg. 3 reg. then           \ UXTH


\ 16 Bit Thumb-2 instruction ?

$BF00 $FF00 opcode? not if else                              \ IT...
                      dup $000F and
                      case
                        $8 of ." it" endof

                        over $10 and if else $8 xor then
                        $C of ." itt" endof
                        $4 of ." ite" endof

                        over $10 and if else $4 xor then
                        $E of ." ittt" endof
                        $6 of ." itet" endof
                        $A of ." itte" endof
                        $2 of ." itee" endof

                        over $10 and if else $2 xor then
                        $F of ." itttt" endof
                        $7 of ." itett" endof
                        $B of ." ittet" endof
                        $3 of ." iteet" endof
                        $D of ." ittte" endof
                        $5 of ." itete" endof
                        $9 of ." ittee" endof
                        $1 of ." iteee" endof
                      endcase
                      space
                      dup $00F0 and 4 rshift condition.
                    then

\ 32 Bit Thumb-2 instruction ?

$E800 $F800 opcode? if disasm-thumb-2 then
$F000 $F000 opcode? if disasm-thumb-2 then


\ If nothing of the above hits: Invalid Instruction... They are not checked for.

\ Try name resolving for blx r0 sequences:

$2000 $FF00 opcode? if dup $FF and destination-r0  ! then \ movs r0, #...
$3000 $FF00 opcode? if dup $FF and destination-r0 +! then \ adds r0, #...
$0000 $F83F opcode? if destination-r0 @                   \ lsls r0, r0, #...
                         over $07C0 and 6 rshift lshift
                       destination-r0 ! then
dup $4780 =         if destination-r0 @ name. then        \ blx r0

drop \ Forget opcode
; \ disasm

\ ------------------------------
\  Single instruction printing
\ ------------------------------

: memstamp \ ( Addr -- ) Shows a memory location nicely
    dup u.8 ." : " h@ u.4 ."   " ;

: disasm-step ( -- )
    disasm-$ @                 \ Note current position
    dup memstamp disasm cr     \ Disassemble one instruction

    begin \ Write out all disassembled memory locations
      2+ dup disasm-$ @ <>
    while
      dup memstamp cr
    repeat
    drop
;

\ ------------------------------
\  Disassembler for definitions
\ ------------------------------

: seec ( -- ) \ Continues to see
  base @ hex cr

  begin
    disasm-$ @ h@           $4770 =  \ Flag: Loop terminates with bx lr
    disasm-$ @ h@ $FF00 and $BD00 =  \ Flag: Loop terminates with pop { ... pc }
    or
    disasm-step
  until

  base !
;

: see ( -- ) \ Takes name of definition and shows its contents from beginning to first ret
  ' disasm-$ !
  seec
;

\ -----------------------------------------------------------------------------
\   A few tools for dictionary wizardy
\ -----------------------------------------------------------------------------

: executablelocation? ( addr -- ? )
  dup  addrinram?              \ In RAM
  over flashvar-here u< and     \ and below the variables and buffers
  swap addrinflash? or           \ or in flash ?
;

: link>flags ( addr -- addr* ) 4 + 1-foldable ;
: link>name  ( addr -- addr* ) 6 + 1-foldable ;
: link>code  ( addr -- addr* ) 6 + skipstring ;

0 variable searching-for
0 variable closest-found

: code>link  ( entrypoint -- addr | 0 ) \ Try to find this code start address in dictionary

    searching-for !
  0 closest-found !

  compiletoram? 0= >r  \ Save current compile mode
  compiletoram          \ Always scan in compiletoram mode, in order to also find definitions in RAM.

  dictionarystart
  begin
    dup link>code searching-for @ = if dup closest-found ! then
    dictionarynext
  until
  drop

  r> if compiletoflash then \ Restore compile mode

  closest-found @
;

: inside-code>link ( addr-inside -- addr | 0 ) \ Try to find this address inside of a definition

  dup executablelocation? not if drop 0 exit then  \ Do not try to find locations which are not executable

    searching-for !
  0 closest-found !

  compiletoram? 0= >r  \ Save current compile mode
  compiletoram          \ Always scan in compiletoram mode, in order to also find definitions in RAM.

  dictionarystart
  begin

    dup link>code searching-for @ u<=
    if \ Is the address of this entry BEFORE the address which is to be found ?
      \ Distance to current   Latest best distance
      searching-for @ over -  searching-for @ closest-found @ -  <
      if dup closest-found ! then \ Is the current entry closer to the address which is to be found ?
    then

    dictionarynext
  until
  drop

  r> if compiletoflash then \ Restore compile mode

  \ Do not cross RAM/Flash borders:

  searching-for @ addrinflash?
  closest-found @ addrinflash? xor if 0 else closest-found @ then
;

: traceinside. ( addr -- )
  inside-code>link if
  ." ( "                 closest-found @ link>code   hex.
  ." + " searching-for @ closest-found @ link>code - hex.
  ." ) "
  closest-found @ link>name ctype
  then
;

: variable>link  ( location -- addr | 0 ) \ Try to find this variable or buffer in flash dictionary

    searching-for !
  0 closest-found !

  compiletoram? 0= >r  \ Save current compile mode
  compiletoram          \ Always scan in compiletoram mode, in order to also find definitions in RAM.

  dictionarystart
  begin

    dup link>flags h@   \ Fetch Flags of current definition
    $7FF0 and            \ Snip off visibility bit and reserved length
    dup          $140 =   \ Variables and buffers are either initialised variables or
    swap          $80 = or \ "0-foldable and reserves uninitialised memory" when defined in flash memory.
                            \ Take care: You cannot easily use $40 bit "0-foldable" to check for variables and buffers in RAM.
    if
      dup link>code execute searching-for @ = if dup closest-found ! then
    then

    dictionarynext
  until
  drop

  r> if compiletoflash then \ Restore compile mode

  closest-found @
;

: variable-name. ( addr -- ) \ Print the name of this variable or buffer, if possible
  dup flashvar-here u< if inside-code>link else variable>link then
  ?dup if link>name ctype then
;
\ -----------------------------------------------------------
\   Cooperative Multitasking
\ -----------------------------------------------------------

\ Configuration:

128 cells constant stackspace \ 128 stack elements for every task

\ Internal stucture of task memory:
\  0: Pointer to next task
\  4: Task currently active ?
\  8: Saved stack pointer
\ 12: Handler for Catch/Throw
\  Parameter stack space
\  Return    stack space

false 0 true flashvar-here 4 cells - 4 nvariable boot-task \ Boot task is active, without handler and has no extra stackspace.
boot-task boot-task ! \ For compilation into RAM only

boot-task variable up \ User Pointer
: next-task  ( -- task )    up @ inline ;
: task-state ( -- state )   up @ 1 cells + inline ;
: save-task  ( -- save )    up @ 2 cells + inline ;
: handler    ( -- handler ) up @ 3 cells + inline ;

: (pause) ( stacks fly around )
    [ $B430 h, ]        \ push { r4  r5 } to save I and I'
    rp@ sp@ save-task !  \ save return stack and stack pointer
    begin
      next-task @ up !     \ switch to next running task
    task-state @ until
    save-task @ sp! rp!  \ restore pointers
    unloop ;              \ pop { r4  r5 } to restore the loop registers

: wake ( task -- ) 1 cells +  true swap ! ; \ Wake a random task (IRQ save)
: idle ( task -- ) 1 cells + false swap ! ;  \ Idle a random task (IRQ save)

\ -------------------------------------------------------
\  Round-robin list task handling - do not use in IRQ !
\ -------------------------------------------------------

: stop ( -- ) false task-state ! pause ; \ Stop current task
: multitask  ( -- ) ['] (pause) hook-pause ! ;
: singletask ( -- ) [']  nop    hook-pause ! ;

: task-in-list? ( task -- ? ) \ Checks if a task is currently inside of round-robin list (do not use in IRQ)
  next-task
  begin
    ( Task-Address )
    2dup = if 2drop true exit then
    @ dup next-task = \ Stop when end of circular list is reached
  until
  2drop false
;

: previous ( task -- addr-of-task-before )
  \ Find the task that has the desired one in its next field
  >r next-task begin dup @ r@ <> while @ repeat rdrop
;

: insert ( task -- ) \ Insert a task into the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if drop else next-task @ over ! next-task ! then
;

: remove ( task -- ) \ Remove a task from the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if dup @ ( task next )
     swap previous ( next previous ) !
  else drop then
;

\ -----------------------------------------
\ Create a new task - do not use in IRQ !
\ -----------------------------------------

: task: ( "name" -- )  stackspace cell+ 2*  4 cells +  buffer: ;

: preparetask ( task continue -- )
  swap >r ( continue R: task )

    \ true  r@ 1 cells + ! \ Currently running
      false r@ 3 cells + ! \ No handler

    r@ 4 cells + stackspace + ( continue start-of-parameter-stack )
      dup   r@ 2 cells + ! \ Start of parameter stack

    dup stackspace + ( continue start-of-parameter-stack start-of-return-stack )
    tuck      ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack )
    2 cells - ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack* ) \ Adjust for saved loop index and limit
    swap  !   ( continue start-of-return-stack ) \ Store the adjusted return stack pointer into the parameter stack
    !         \ Store the desired entry address at top of the tasks return stack

  r> insert
;

: activate ( task --   R: continue -- )
  true over 1 cells + ! \ Currently running
  r> preparetask
;

: background ( task --   R: continue -- )
  false over 1 cells + ! \ Currently idling
  r> preparetask
;

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

: tasks ( -- ) \ Show tasks currently in round-robin list
  hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.

  \ Start with current task.
  next-task cr

  begin
    ( Task-Address )
    dup             ." Task Address: " hex.
    dup           @ ." Next Task: " hex.
    dup 1 cells + @ ." State: " hex.
    dup 2 cells + @ ." Stack: " hex.
    dup 3 cells + @ ." Handler: " hex. cr

    @ dup next-task = \ Stop when end of circular list is reached
  until
  drop

  hook-pause ! \ Restore old state of multitasking
;

\ --------------------------------------------------
\  Exception handling
\ --------------------------------------------------

: catch ( x1 .. xn xt -- y1 .. yn throwcode / z1 .. zm 0 )
    [ $B430 h, ]  \ push { r4  r5 } to save I and I'
    sp@ >r handler @ >r rp@ handler !  execute
    r> handler !  rdrop  0 unloop ;

: throw ( throwcode -- )  dup IF
	handler @ 0= IF false task-state ! THEN \ unhandled error: stop task
	handler @ rp! r> handler ! r> swap >r sp! drop r>
	UNLOOP  EXIT
    ELSE  drop  THEN ;

\ Requires dictionary-tools.txt

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

: tasks ( -- ) \ Show tasks currently in round-robin list
  hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.

  \ Start with current task.
  next-task cr

  begin
    ( Task-Address )
    dup             ." Task Address: " hex.
    dup           @ ." Next Task: " hex.
    dup 1 cells + @ ." State: " hex.
    dup 2 cells + @ ." Stack: " hex.
    dup 3 cells + @ ." Handler: " hex.
    dup             ." Name: " variable-name. cr

    @ dup next-task = \ Stop when end of circular list is reached
  until
  drop

  hook-pause ! \ Restore old state of multitasking
;

\ --------------------------------------------------
\  Multitasking debug tools
\ --------------------------------------------------

:  depth ( -- n ) up @ boot-task = if  depth    else up @ 4 cells stackspace    + + sp@ - 2 arshift then ;
: rdepth ( -- n ) up @ boot-task = if rdepth 1- else up @ 4 cells stackspace 2* + + rp@ - 2 arshift then ;

: .s ( -- )
  base @ >r decimal depth ." Stack: [" . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick .
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup . ."  *>" cr
;

: u.s ( -- )
  base @ >r decimal depth ." Stack: [" . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick u.
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup u. ."  *>" cr
;

: h.s ( -- )
  base @ >r decimal depth ." Stack: [" . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick hex.
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup hex. ."  *>" cr
;

\ -----------------------------------------------------------------------------
\   Various small tools
\ -----------------------------------------------------------------------------

: 2and ( d1 d2 -- d ) ( l2 h2 l1 h1 ) rot and ( l2 l1 h ) -rot and ( h l ) swap 4-foldable ;
: 2or  ( d1 d2 -- d ) ( l2 h2 l1 h1 ) rot or  ( l2 l1 h ) -rot or  ( h l ) swap 4-foldable ;
: 2xor ( d1 d2 -- d ) ( l2 h2 l1 h1 ) rot xor ( l2 l1 h ) -rot xor ( h l ) swap 4-foldable ;

: 2lshift  ( ud u -- ud* ) 0 ?do dshl loop 3-foldable ;
: 2rshift  ( ud u -- ud* ) 0 ?do dshr loop 3-foldable ;
: 2arshift (  d u --  d* ) 0 ?do d2/  loop 3-foldable ;

: d0<> ( d -- ? ) d0= not 2-foldable ;

: u.4 ( u -- ) 0 <# # # # # #> type ;
: u.2 ( u -- ) 0 <# # # #> type ;

: h.4 ( u -- ) base @ hex swap  u.4  base ! ;
: h.2 ( u -- ) base @ hex swap  u.2  base ! ;

\ -----------------------------------------------------------------------------
\   I/O pin primitives
\ -----------------------------------------------------------------------------

$40020000 constant GPIO-BASE
      $00 constant GPIO.MODER   \ Reset 0 Port Mode Register
                                \   00=Input  01=Output  10=Alternate  11=Analog
      $04 constant GPIO.OTYPER  \ Reset 0 Port Output type register
                                \   (0) Push/Pull vs. (1) Open Drain
      $08 constant GPIO.OSPEEDR \ Reset 0 Output Speed Register
                                \   00=2 MHz  01=25 MHz  10=50 MHz  11=100 MHz
      $0C constant GPIO.PUPDR   \ Reset 0 Pullup / Pulldown 
                                \   00=none  01=Pullup  10=Pulldown
      $10 constant GPIO.IDR     \ RO      Input Data Register
      $14 constant GPIO.ODR     \ Reset 0 Output Data Register
      $18 constant GPIO.BSRR    \ WO      Bit set/reset register
      $20 constant GPIO.AFRL    \ Reset 0 Alternate function  low register
      $24 constant GPIO.AFRH    \ Reset 0 Alternate function high register

: bit ( u -- u )  \ turn a bit position into a single-bit mask
  1 swap lshift  1-foldable ;
: bit! ( mask addr f -- )  \ set or clear specified bit(s)
  if bis! else bic! then ;

\ -----------------------------------------------------------------------------

: io ( port# pin# -- pin )  \ combine port and pin into single int
  swap 8 lshift or  2-foldable ;
: io# ( pin -- u )  \ convert pin to bit position
  $1F and  1-foldable ;
: io-mask ( pin -- u )  \ convert pin to bit mask
  io# bit  1-foldable ;
: io-port ( pin -- u )  \ convert pin to port number (A=0, B=1, etc)
  8 rshift  1-foldable ;
: io-base ( pin -- addr )  \ convert pin to GPIO base address
  $F00 and 2 lshift GPIO-BASE +  1-foldable ;

: 'f ( -- flags ) token find nip ;

: (io@)  (   pin -- pin* addr )
  dup io-mask swap io-base GPIO.IDR      +   1-foldable ;
: (ioc!) (   pin -- pin* addr )
  dup io-mask swap io-base GPIO.BSRR 2 + +   1-foldable ;
: (ios!) (   pin -- pin* addr )
  dup io-mask swap io-base GPIO.BSRR     +   1-foldable ;
: (iox!) (   pin -- pin* addr )
  dup io-mask swap io-base GPIO.ODR      +   1-foldable ;
: (io!)  ( f pin -- pin* addr )
  swap 0= $10 and + dup io-mask swap io-base GPIO.BSRR +   2-foldable ;

: io@ ( pin -- f )  \ get pin value (0 or -1)
  (io@)  bit@ exit [ $1000 setflags 2 h, ' (io@)  ,
  'f (io@)  h, ' bit@ , 'f bit@ h, ] ;
: ioc! ( pin -- )  \ clear pin to low
  (ioc!)    ! exit [ $1000 setflags 2 h, ' (ioc!) ,
  'f (ioc!) h, '   h! , 'f   h! h, ] ;
: ios! ( pin -- )  \ set pin to high
  (ios!)    ! exit [ $1000 setflags 2 h, ' (ios!) ,
  'f (ios!) h, '   h! , 'f   h! h, ] ;
: iox! ( pin -- )  \ toggle pin, not interrupt safe
  (iox!) xor! exit [ $1000 setflags 2 h, ' (iox!) ,
  'f (iox!) h, ' xor! , 'f xor! h, ] ;

: io! ( f pin -- )  \ set pin value
  (io!) ! exit
  [ $1000 setflags
    7 h,
    ' (ios!) , 'f  (ios!) h,
    ' rot    , 'f  rot    h,
    ' 0=     , 'f  0=     h,
      4      ,     $2000  h,
    ' and    , 'f  and    h,
    ' +      , 'f  +      h,
    ' !      , 'f  !      h, ] ;

\ -----------------------------------------------------------------------------

\ b6 = type, b5-4 = pull, b3-2 = mode, b1..0 = speed

%0000000 constant IMODE-FLOAT  \ input, floating
%0010000 constant IMODE-HIGH   \ input, pull up
%0100000 constant IMODE-LOW    \ input, pull down
%0001100 constant IMODE-ADC    \ input, analog

%0001010 constant OMODE-AF-PP  \ alternate function, push-pull
%1001010 constant OMODE-AF-OD  \ alternate function, open drain
%1011010 constant OMODE-AF-OD-HIGH  \ alternate function, open drain, pull up
%0000110 constant OMODE-PP     \ output, push-pull
%1000110 constant OMODE-OD     \ output, open drain
%1010110 constant OMODE-OD-HIGH  \ output, open drain, pull up

-2 constant OMODE-WEAK  \ add to OMODE-* for 400 KHz iso 10 MHz drive
-1 constant OMODE-SLOW  \ add to OMODE-* for 2 MHz iso 10 MHz drive
 1 constant OMODE-FAST  \ add to OMODE-* for 35 MHz iso 10 MHz drive


: io-config ( bits pin offset -- )  \ replace 2 bits in specified h/w register
  over io-base + >r   ( bits pin R: addr )
  io# shl             ( bits shift R: addr )
  %11 over lshift     ( bits shift mask R: addr )
  r@ @ swap bic       ( bits shift cleared R: addr )
  rot %11 and         ( shift cleared value R: addr )
  rot lshift or r> ! ;

: io-mode! ( mode pin -- )  \ set the CNF and MODE bits for a pin
  over          over GPIO.OSPEEDR io-config
  over 2 rshift over GPIO.MODER   io-config
  over 4 rshift over GPIO.PUPDR   io-config
  \ open drain mode config
  dup io-mask swap io-base GPIO.OTYPER +
  ( mode mask addr ) rot %1000000 and bit! ;

: io-modes! ( mode pin mask -- )  \ shorthand to config multiple pins of a port
  16 0 do
    i bit over and if
      >r  2dup ( mode pin mode pin R: mask ) $F bic i or io-mode!  r>
    then
  loop 2drop drop ;

: io. ( pin -- )  \ display readable GPIO registers associated with a pin
  cr
   ." PIN " dup io#  dup .  10 < if space then
  ." PORT " dup io-port [char] A + emit
  io-base
    ."   MODER " dup @ hex. 4 +
  ."    OTYPER " dup @ h.4  4 +
  ."   OSPEEDR " dup @ hex. 4 +
      ."  PUPD " dup @ hex. 4 +
  cr 14 spaces
       ."  IDR " dup @ h.4  4 +
       ."  ODR " dup @ h.4  12 +
    ."    AFRL " dup @ hex. 4 +
       ." AFRH " dup @ hex. drop ;

\ -----------------------------------------------------------------------------

 0 0  io constant PA0      1 0  io constant PB0      2 0  io constant PC0 
 0 1  io constant PA1      1 1  io constant PB1      2 1  io constant PC1 
 0 2  io constant PA2      1 2  io constant PB2      2 2  io constant PC2 
 0 3  io constant PA3      1 3  io constant PB3      2 3  io constant PC3 
 0 4  io constant PA4      1 4  io constant PB4      2 4  io constant PC4 
 0 5  io constant PA5      1 5  io constant PB5      2 5  io constant PC5 
 0 6  io constant PA6      1 6  io constant PB6      2 6  io constant PC6 
 0 7  io constant PA7      1 7  io constant PB7      2 7  io constant PC7 
 0 8  io constant PA8      1 8  io constant PB8      2 8  io constant PC8 
 0 9  io constant PA9      1 9  io constant PB9      2 9  io constant PC9 
 0 10 io constant PA10     1 10 io constant PB10     2 10 io constant PC10
 0 11 io constant PA11     1 11 io constant PB11     2 11 io constant PC11
 0 12 io constant PA12     1 12 io constant PB12     2 12 io constant PC12
 0 13 io constant PA13     1 13 io constant PB13     2 13 io constant PC13
 0 14 io constant PA14     1 14 io constant PB14     2 14 io constant PC14
 0 15 io constant PA15     1 15 io constant PB15     2 15 io constant PC15
 

 3 0  io constant PD0      4 0  io constant PE0
 3 1  io constant PD1      4 1  io constant PE1
 3 2  io constant PD2      4 2  io constant PE2
 3 3  io constant PD3      4 3  io constant PE3
 3 4  io constant PD4      4 4  io constant PE4
 3 5  io constant PD5      4 5  io constant PE5
 3 6  io constant PD6      4 6  io constant PE6
 3 7  io constant PD7      4 7  io constant PE7
 3 8  io constant PD8      4 8  io constant PE8
 3 9  io constant PD9      4 9  io constant PE9
 3 10 io constant PD10     4 10 io constant PE10
 3 11 io constant PD11     4 11 io constant PE11
 3 12 io constant PD12     4 12 io constant PE12
 3 13 io constant PD13     4 13 io constant PE13
 3 14 io constant PD14     4 14 io constant PE14
 3 15 io constant PD15     4 15 io constant PE15

 

\ -----------------------------------------------------------------------------
\   Delay with Systick-Timer
\ -----------------------------------------------------------------------------

$E000E010 constant NVIC_ST_CTRL_R
$E000E014 constant NVIC_ST_RELOAD_R      
$E000E018 constant NVIC_ST_CURRENT_R

: init-delay ( -- )
    \ Start free running Systick Timer without Interrupts
  
    \ Disable SysTick during setup
    0 NVIC_ST_CTRL_R !

    \ Maximum reload value for 24 bit timer
    $00FFFFFF NVIC_ST_RELOAD_R !

    \ Any write to current clears it
    0 NVIC_ST_CURRENT_R !

    \ Enable SysTick with core clock
    %101 NVIC_ST_CTRL_R !
;

: delay-ticks ( ticks -- ) \  Tick = 1/4MHz = 250 ns
  8 lshift
  NVIC_ST_CURRENT_R @ 8 lshift

  begin pause
    2dup
    NVIC_ST_CURRENT_R @ 8 lshift
    -
    u<=
  until
  2drop
;

\ Values for 16 MHz. Change accordingly.

: us ( us -- ) 16 * delay-ticks ;
: ms ( ms -- ) 0 ?do 16000 delay-ticks loop ;


\ -----------------------------------------------------------------------------
\  RGB LED
\ -----------------------------------------------------------------------------

PC7 constant led-red
PB1 constant led-green
PB0 constant led-blue

: init-led ( -- )
  led-red ioc! led-green ioc! led-blue ioc!
  OMODE-PP dup led-red   io-mode!
           dup led-green io-mode!
               led-blue  io-mode!
;

\ -----------------------------------------------------------------------------
\  Keyboard scan
\ -----------------------------------------------------------------------------

\  The keyboard is a matrix that is laid out as follow:
\  
\       |  PC0 |  PC1 | PC2  | PC3  | PC4  | PC5  |
\  -----+------+------+------+------+------+------+
\   PE0 | K_A1 | K_A2 | K_A3 | K_A4 | K_A5 | K_A6 |
\  -----+------+------+------+------+------+------+
\   PE1 | K_B1 | K_B2 |   8  |   9  |  10  |  11  |
\  -----+------+------+------+------+------+------+
\   PE2 | K_C1 | K_C2 | K_C3 | K_C4 | K_C5 | K_C6 |
\  -----+------+------+------+------+------+------+
\   PE3 | K_D1 | K_D2 | K_D3 | K_D4 | K_D5 | K_D6 |
\  -----+------+------+------+------+------+------+
\   PE4 | K_E1 | K_E2 | K_E3 | K_E4 | K_E5 | K_E6 |
\  -----+------+------+------+------+------+------+
\   PE5 | K_F1 | K_F2 | K_F3 | K_F4 | K_F5 |  35  |
\  -----+------+------+------+------+------+------+
\   PE6 | K_G1 | K_G2 | K_G3 | K_G4 | K_G5 |  41  |
\  -----+------+------+------+------+------+------+
\   PE7 | K_H1 | K_H2 | K_H3 | K_H4 | K_H5 |  47  |
\  -----+------+------+------+------+------+------+
\   PE8 | K_I1 | K_I2 | K_I3 | K_I4 | K_I5 |  53  |
\  -----+------+------+------+------+------+------|
\  
\   We decide to drive the rows (PE0-8) and read the columns (PC0-5).
\  
\   To avoid short-circuits, the pins E0-E8 will not be standard outputs but
\   only open-drain. Open drain means the pin is either driven low or left
\   floating.
\   When a user presses multiple keys, a connection between two rows can happen.
\   If we don't use open drain outputs, this situation could trigger a short
\   circuit between an output driving high and another driving low.
\  
\   If the outputs are open-drain, this means that the input must be pulled up.
\   So if the input reads "1", this means the key is in fact *not* pressed, and
\   if it reads "0" it means that there's a short to an open-drain output. Which
\   means the corresponding key is pressed.

: init-keyboard ( -- )

  %000000000 16 lshift %111111111 or  PE0 io-base GPIO.BSRR +  !   \ All floating

  OMODE-OD   PE0 %111111111 io-modes! \ Set PE0 to PE8 as open drain outputs
  IMODE-HIGH PC0    %111111 io-modes! \ Set PC0 to PC5 as inputs with pullups          

\  OMODE-OD
\  dup PE0 io-mode! dup PE1 io-mode! dup PE2 io-mode! dup PE3 io-mode!
\  dup PE4 io-mode! dup PE5 io-mode! dup PE6 io-mode! dup PE7 io-mode!
\      PE8 io-mode!
  
\  IMODE-HIGH
\  dup PC0 io-mode! dup PC1 io-mode! dup PC2 io-mode! dup PC3 io-mode!
\  dup PC4 io-mode!     PC5 io-mode!

;

: scan-keyboard-row ( ud -- ud* )
  6 2lshift  swap  10 us  PC0 io-base GPIO.IDR + @ not %111111 and  or  swap
;

: scan-keyboard ( -- ud )

  0.

  %100000000 16 lshift %011111111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %010000000 16 lshift %101111111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %001000000 16 lshift %110111111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000100000 16 lshift %111011111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000010000 16 lshift %111101111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000001000 16 lshift %111110111 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000000100 16 lshift %111111011 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000000010 16 lshift %111111101 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row
  %000000001 16 lshift %111111110 or  PE0 io-base GPIO.BSRR +  !  scan-keyboard-row

  %000000000 16 lshift %111111111 or  PE0 io-base GPIO.BSRR +  !  \ All floating to reduce current consumption
;

: scan-keyboard-debounce ( -- ud )
  0. 16 0 do scan-keyboard 2or loop
;

\ -----------------------------------------------------------------------------
\  Ring buffers by Jean-Claude Wippler
\ -----------------------------------------------------------------------------

\ Ring buffers, for serial ports, etc - size must be 4..256 and power of 2
\ TODO setup is a bit messy right now, should put buffer: word inside init

\ Each ring needs 4 extra bytes for internal housekeeping:
\   addr+0 = ring mask, i.e. N-1
\   addr+1 = put index: 0..255 (needs to be masked before use)
\   addr+2 = get index: 0..255 (needs to be masked before use)
\   addr+3 = spare
\   addr+4..addr+4+N-1 = actual ring buffer, N bytes
\ Example:
\   16 4 + buffer: buf  buf 16 init-ring

: init-ring ( addr size -- )  \ initialise a ring buffer
  1- swap !  \ assumes little-endian so mask ends up in ring+0
;

: c++@ ( addr -- b addr+1 ) dup c@ swap 1+ ;  \ fetch and autoinc byte ptr

: ring-step ( ring 1/2 -- addr )  \ common code for saving and fetching
  over + ( ring ring-g/p ) dup c@ >r ( ring ring-g/p R: g/p )
  dup c@ 1+ swap c!  \ increment byte under ptr
  dup c@ r> and swap 4 + + ;

: ring# ( ring -- u )  \ return current number of bytes in the ring buffer
\ TODO could be turned into a single @ word access and made interrupt-safe
  c++@ c++@ c++@ drop - and ;
: ring? ( ring -- f )  \ true if the ring can accept more data
  dup ring# swap c@ < ;
: >ring ( b ring -- )  \ save byte to end of ring buffer
  1 ring-step c! ;
: ring> ( ring -- b )  \ fetch byte from start of ring buffer
  2 ring-step c@ ;

\ -----------------------------------------------------------------------------
\  Terminal injection
\ -----------------------------------------------------------------------------

128 4 + buffer: character-ring   \ Character buffer for "key"

: inject-character ( -- )
  character-ring ring?
  if
    character-ring >ring
  else
    drop \ Forget characters which would overflow the ring buffer.
  then
;

: inject-string ( addr len -- )
  0 ?do
    dup c@ inject-character
    1+
  loop
  drop
;

: ring-key? ( -- ? )
  serial-key? if serial-key inject-character then
  character-ring ring# 0<>
;

: ring-key ( -- c )
  begin ring-key? until
  character-ring ring>
;

: enable-ring ( -- )
  character-ring 128 init-ring
  ['] ring-key  hook-key  !
  ['] ring-key? hook-key? !
;

: disable-ring ( -- )
  ['] serial-key  hook-key  !
  ['] serial-key? hook-key? !  
;

\ -----------------------------------------------------------------------------
\  Sleep mode
\ -----------------------------------------------------------------------------

false variable just-woke-up

: sleep-a-while ( -- )

  \ cr ." Entering sleep mode..." cr

  singletask
  led-green ioc!

  \ Insert a power down sequence here, perhaps cutting clock to peripherals
  \ Simplest possibility: Divide clock down to a very low frequency.

  \ Prepare the row which carries the power button
  %000000010 16 lshift %111111101 or  PE0 io-base GPIO.BSRR +  !
  10 us

  \ Simulate behaviour by busy waiting for PC1 going low
  begin PC1 io@ not until

  \ Insert a power up sequence here, reenabling and initialising peripherals

  true just-woke-up !  
  led-green ios!
  multitask

  \ cr ." Welcome back !" cr cr
;

\ -----------------------------------------------------------------------------
\  Key mapping
\ -----------------------------------------------------------------------------

0. 2variable    last-keys
0. 2variable current-keys

: key-press ( xd -- ? )
  2dup current-keys 2@ 2and d0<>
  -rot    last-keys 2@ 2and d0=
  and
;

: key-release ( xd -- ? )
  2dup current-keys 2@ 2and d0=
  -rot    last-keys 2@ 2and d0<>
  and
;

false variable shift-lock
false variable alpha-lock

: normal?     ( -- ? ) shift-lock @ not alpha-lock @ not and ;
: shift?      ( -- ? ) shift-lock @     alpha-lock @ not and ;
: alpha?      ( -- ? ) shift-lock @ not alpha-lock @     and ;
: shiftalpha? ( -- ? ) shift-lock @     alpha-lock @     and ;

: keym
  postpone key-press
  postpone if

    postpone normal?
    postpone if
    postpone s"
    postpone inject-string
    postpone then

    postpone shift?
    postpone if
    postpone s"
    postpone inject-string
    postpone then

    postpone alpha?
    postpone if
    postpone s"
    postpone inject-string
    postpone then

    postpone shiftalpha?
    postpone if
    postpone s"
    postpone inject-string
    postpone then

  postpone then
  immediate
;

: keymap ( -- )

  \ ---------------------------------------------
  $00000000.00000001 key-press if 27 inject-character 91 inject-character 68 inject-character then \ Cursor left
  $00000000.00000002 key-press if 27 inject-character 91 inject-character 65 inject-character then \ Cursor up
  $00000000.00000004 key-press if 27 inject-character 91 inject-character 66 inject-character then \ Cursor down
  $00000000.00000008 key-press if 27 inject-character 91 inject-character 67 inject-character then \ Cursor right
  \ ---------------------------------------------
  $00000000.00000010 key-press if 27 inject-character 91 inject-character 72 inject-character then \ OK --> Pos1
  $00000000.00000020 key-press if 27 inject-character 91 inject-character 70 inject-character then \ Return key --> End
  $00000000.00000040 key-press if 4 @ execute then \ Home --> Restart Mecrisp-Stellaris
  $00000000.00000080 key-release if just-woke-up @ if false just-woke-up ! else sleep-a-while then then \ Power button --> Sleep mode
  \ ---------------------------------------------
  $00000000.00001000 key-press if -1 shift-lock xor! then
  $00000000.00002000 key-press if -1 alpha-lock xor! then
  $00000000.00004000 keym x,n,t"cut":":"
  $00000000.00008000 keym var"copy";";"
  $00000000.00010000 keym Nut&Bolt"paste"'"'"
  $00000000.00020000 key-press if 8 inject-character then \ Backspace
  \ ---------------------------------------------  
  $00000000.00040000 keym e^x"["a"A"
  $00000000.00080000 keym ln"]"b"B"
  $00000000.00100000 keym log"{"c"C"
  $00000000.00200000 keym i"}"d"D"
  $00000000.00400000 keym ,"_"e"E"
  $00000000.00800000 keym x^y"sto>"f"F"
  \ ---------------------------------------------
  $00000000.01000000 keym sin"asin"g"G"
  $00000000.02000000 keym cos"acos"h"H"
  $00000000.04000000 keym tan"atan"i"I"
  $00000000.08000000 keym Pi"="j"J"
  $00000000.10000000 keym sqrt"<"k"K"
  $00000000.20000000 keym ^2">"l"L"
  \ ---------------------------------------------
  $00000000.40000000 keym 7"7"m"M"
  $00000000.80000000 keym 8"8"n"N"
  $00000001.00000000 keym 9"9"o"O"
  $00000002.00000000 keym ("("p"P"
  $00000004.00000000 keym )")"q"Q"
  \ ---------------------------------------------
  $00000010.00000000 keym 4"4"r"R"
  $00000020.00000000 keym 5"5"s"S"
  $00000040.00000000 keym 6"6"t"T"
  $00000080.00000000 keym *"*"u"U"
  $00000100.00000000 keym /"/"v"V"
  \ ---------------------------------------------
  $00000400.00000000 keym 1"1"w"W"
  $00000800.00000000 keym 2"2"x"X"
  $00001000.00000000 keym 3"3"y"Y"
  $00002000.00000000 keym +"+"z"Z"
  $00004000.00000000 keym -"-" " "
  \ ---------------------------------------------
  $00010000.00000000 keym 0"0"?"?"
  $00020000.00000000 keym ."."!"!"
  $00040000.00000000 keym x10^x"x10^x"x10^x"x10^x"
  $00080000.00000000 key-press if 32 inject-character then \ Space \ keym Ans"Ans"Ans"Ans"
  $00100000.00000000 key-press if 10 inject-character then \ LF    \ keym EXE"EXE"EXE"EXE"
  \ ---------------------------------------------
;

\ -----------------------------------------------------------------------------
\  Keyboard handling
\ -----------------------------------------------------------------------------

: keyboard-handler ( -- )
  scan-keyboard-debounce current-keys 2!

  current-keys 2@ last-keys 2@ 2xor d0<>   \ Any changes in key state ?
  if
    \ ." Key change: " current-keys 2@ hex. hex. cr
    keymap \ Insert a lot of handling here !
  then

  current-keys 2@ last-keys 2!
;

\ -----------------------------------------------------------------------------
\  Task for handling the keyboard in background
\ -----------------------------------------------------------------------------

task: keyboard-task

: keyboard& ( -- )
  keyboard-task activate

    begin
      keyboard-handler
      pause \ Pause is called in the delay used in scan-keyboard, therefore strictly speaking no pause is necessary here.
    again
;

: keyboard-into-terminal ( -- )

  init-led
  init-delay
  init-keyboard
  enable-ring

  led-green ios!

  multitask
  keyboard&
;

\
\    file: display.txt  (forth sourcecode)
\ purpose: Display-driver for the NUMWORKS graphing calculator
\
\ created: 2018-06-30 by wost (wost@ewost.de)
\ licence: GPL3
\
\ based on work by:
\     - Matthias Koch   mecrisp.sourceforge.net
\     - JeeLabs         jeelabs.org
\     - NUMWORKS        numworks.com
\
\ needs: 
\     - io.txt
\     - keyboard.txt   ( us ms init-delay )
\
\ changelog:
\     - 2018-06-30  Initial version
\     - 2018-07-04  tidy up


\ --------------------------------------------------
\ LCD - Backlight control
\ --------------------------------------------------

\ This piece of code controls the RT9365 LED driver.
\ This chip allows the brightness to be set to 16 different values. It starts
\ at full brightness on power-on / after shutdown. Applying a pulse on the EN pin
\ will select the next value in decreasing order. Once it reaches the minimal value,
\ the next pulse will loop back to full brightness.

PC6 constant BACKLIGHT-ENABLE-PIN  \               1 : backlight on
                                   \               0 : backlight off
      \    short negative pulse ( 0.5 - 500 us ) : decrease brightness by one level
      \  long negative pulse or level ( > 3 ms ) : shutdown, driver eventually starts at max. brightness


: init-backlight ( -- )  \ Sets enable-pin to push/pull and restarts the LED-Driver.
                         \ This automatically drives the LED's at full power.
                         \ You should then decrease the brightness to a suitable level to
                         \ reduce power consumption and increase the lifespan of the LED's.
  BACKLIGHT-ENABLE-PIN ioc!
  OMODE-PP BACKLIGHT-ENABLE-PIN io-mode!
  3500 us  \ negative level > 3000 us (3 ms) shuts down the LED-driver 
  BACKLIGHT-ENABLE-PIN ios!
  35 us    \ LED-Driver needs > 30 us to reach full brightness
           \   and to be ready for next pulses
;

: shutdown-backlight ( -- )  \ Shuts down the LED-Driver.
                             \ Call 'init-backlight' again to start over.
  BACKLIGHT-ENABLE-PIN ioc!
  3500 us  \ negative pulse > 3000 us (3 ms) shuts down the LED-Driver 
;

: decrease-backlight ( -- )  \ Reduces the brightness by one step (16 levels available).
                             \ If the brightness was at the lowest level, it rolls over to max. brightness.
  BACKLIGHT-ENABLE-PIN ioc!
  1 us  \ negative pulse must be > 0.5 us
  BACKLIGHT-ENABLE-PIN ios!
  1 us  \ to ensure that time between pulses is > 0.5 us 
;

: increase-backlight ( -- )  \ Raises the brightness by one step (16 levels available)
                             \ If the brightness was at the highest level, it is set to min. brightness.
  15 0  \ decrease 15 times means increase by 1 (16-step roll over)
  do
      decrease-backlight
  loop
;

\ --------------------------------------------------
\ DISPLAY
\ --------------------------------------------------

\  LCD driver for ST7789V chip, connected as 16-bit parallel SRAM via FSMC.
\  This chip keeps a whole frame in SRAM memory and feeds it to the LCD panel as
\  needed. We use the STM32's FSMC to drive the bus between the ST7789V. Once
\  configured, we only need to write in the address space of the MCU to actually
\  send commands and some data to the LCD controller.
\
\   Pin | Role              | Mode                  | Function | Note
\  -----+-------------------+-----------------------+----------|------
\   PA2 | LCD D4            | Alternate Function 12 | FSMC_D4  |
\   PA3 | LCD D5            | Alternate Function 12 | FSMC_D5  |
\   PA4 | LCD D6            | Alternate Function 12 | FSMC_D6  |
\       |                   |                       |          |
\  PB12 | LCD D13           | Alternate Function 12 | FSMC_D13 |
\       |                   |                       |          |
\   PD0 | LCD D2            | Alternate Function 12 | FSMC_D2  |
\   PD1 | LCD D3            | Alternate Function 12 | FSMC_D3  |
\   PD4 | LCD read signal   | Alternate Function 12 | FSMC_NOE |
\   PD5 | LCD write signal  | Alternate Function 12 | FSMC_NWE |
\   PD7 | LCD chip select   | Alternate Function 12 | FSMC_NE1 | Memory bank 1
\   PD9 | LCD D14           | Alternate Function 12 | FSMC_D14 |
\  PD10 | LCD D15           | Alternate Function 12 | FSMC_D15 |
\  PD11 | LCD data/command  | Alternate Function 12 | FSMC_A16 | Data/Command is address bit 16
\  PD14 | LCD D0            | Alternate Function 12 | FSMC_D0  |
\  PD15 | LCD D1            | Alternate Function 12 | FSMC_D1  |
\       |                   |                       |          |
\  PE10 | LCD D7            | Alternate Function 12 | FSMC_D7  |
\  PE11 | LCD D8            | Alternate Function 12 | FSMC_D8  |
\  PE12 | LCD D9            | Alternate Function 12 | FSMC_D9  |
\  PE13 | LCD D10           | Alternate Function 12 | FSMC_D10 |
\  PE14 | LCD D11           | Alternate Function 12 | FSMC_D11 |
\  PE15 | LCD D12           | Alternate Function 12 | FSMC_D12 |
\       |                   |                       |          |
\  PB14 | LCD power         | Output                |          | LCD controller is powered directly from GPIO
\   PE9 | LCD reset         | Output                |          |
\  PB13 | LCD ext. command  | Output                |          | this pin is always set to high
\       |                   |                       |          |
\  PB10 | LCD tearing effect| Input                 |          | to eliminate screen-flicker
\
\
\  The STM32 FSMC supports two kinds of memory access modes :
\   - Base modes (1 and 2), which use the same timings for reads and writes
\   - Extended modes (named A to D), which can be customized further.
\   The LCD panel can be written to faster than it can be read from, therefore
\   we want to use one of the extended modes.
\
\  We now need to set the actual timings. First, the FSMC and LCD specs don't
\  use the same names. Here's the mapping:
\  
\  FSMC | LCD
\  -----+-----
\   NOE | RDX
\   NWE | WRX
\   NE1 | CSX
\   A16 | D/CX
\   Dn  | Dn
\
\  We need to set the values of the BTR and BWTR which gives the timings for
\  reading and writing. Note that the STM32 datasheet doesn't take into
\  account the time needed to actually switch from one logic state to another,
\  whereas the ST7789V one does, so we'll add T(R) and T(F) as needed.
\  Last but not least, timings on the STM32 have to be expressed in terms of
\  HCLK = 1/96MHz = 10.42ns.
\    - We'll pick Mode A which corresponds to SRAM with OE toggling
\    - ADDSET = T(AST) + T(F) = 0ns + 15ns = 2 HCLK
\    - ADDHLD is unused in this mode, set to 0
\    - DATAST(read) = T(RDLFM) + T(R) = 355ns + 15ns = 36 HCLK
\      DATAST(write) = T(WRL) + T(R) = 15ns + 15ns = 3 HCLK
\    - BUSTURN(read) = T(RDHFM) + T(F) = 90ns + 15ns = 10 HCLK
\      BUSTURN(write) = T(RDHFM) + T(F) = 15ns + 15ns = 3 HCLK


$40023800 constant RCC-BASE

$40023830 constant RCC-AHB1ENR   \ AHB1 peripheral clock enable register ( GPIO's, DMA1, DMA2, CRC )
$40023834 constant RCC-AHB2ENR   \ AHB2 peripheral clock enable register ( OTGFS, RNG )
$40023838 constant RCC-AHB3ENR   \ AHB3 peripheral clock enable register ( QSPI, FSMC )

$40023840 constant RCC-APB1ENR   \ APB1 peripheral clock enable register ( TIMER, USART, SPI, I2C, CAN, etc )
$40023844 constant RCC-APB2ENR   \ APB2 peripheral clock enable register ( TIMER, USART, ADC, SPI, etc )
\ there is also a set of AHBx/APBx peripheral clock enable registers for low power mode

$A0000000 constant FSMC-BCR1
$A0000004 constant FSMC-BTR1
$A0000104 constant FSMC-BWTR1


: init-fsmc ( -- )  \ Initialize the 'Flexible static memory controller' (FSMC)

  0 bit RCC-AHB3ENR bis!  \ enable FSMC clock ( Bit-0 )

\  Register FSMC-BCR1
\  10987654321098765432109876543210  \ bit-number 0-31
\  00000000000000000011000011011011  \ Reset-values. Oddity: Bit7 is marked as reserved but set by reset
\  ++++++++--------++++++++--------  \ grouping for better readability
  %00000000000000000011000011010001 FSMC-BCR1 !
\  ----------ponmmmlkjih-gf-eddccba  \  '-' means reserved
\
\    * value set by epsilon code
\
\   a:1  *MBKEN
\   b:0  *MUXEN
\  cc:00 *MTYP  %00=SRAM  %01=PSRAM(CRAM)  %10=FLASH  %11=reserved
\  dd:01 *MWID  %00=8-bit  %01=16-bit  %10=reserved   %11=reserved
\   e:1   FACCEN
\   f:0   BURSTEN
\   g:0   WAITPOL
\   h:0   WAITCFG
\   i:1  *WREN
\   j:1   WAITEN
\   k:1  *EXTMOD
\   l:0   ASYNCWAIT
\ mmm:000 CPSIZE  %000=no_burst_split (Only for Cellular RAM)
\   n:0   CBURSTRW
\   o:0   CCLKEN
\   p:0   WFDIS


\  Register FSMC-BTR1  Read timings
\  10987654321098765432109876543210  \ bit-number 0-31
\  00001111111111111111111111111111  \ Reset-values
\  ++++++++--------++++++++--------  \ grouping for better readability
  %00001111111110100010010000000010 FSMC-BTR1 !
\  --ggffffeeeeddddccccccccbbbbaaaa  \  -:reserved
\
\    * value set by epsilon code  
\
\      aaaa:0010     *ADDSET   2
\      bbbb:0000     *ADDHLD   0
\  cccccccc:00100100 *DATAST  36
\      dddd:1010     *BUSTURN 10
\      eeee:1111      CLKDIV
\      ffff:1111      DATLAT
\        gg:00       *ACCMOD MODE_A  %00=A  %01=B  %10=C  %11=D


\  Register FSMC-BWTR1  Write timings
\  10987654321098765432109876543210  \ bit-number 0-31
\  00001111111111111111111111111111  \ Reset-values
\  ++++++++--------++++++++--------  \ grouping for better readability
  %00001111111100110000001100000010 FSMC-BWTR1 !
\  --ee--------ddddccccccccbbbbaaaa  \  -:reserved
\
\    * value set by epsilon code  
\
\      aaaa:0010     *ADDSET  2
\      bbbb:0000     *ADDHLD  0
\  cccccccc:00000011 *DATAST  3
\      dddd:0011     *BUSTURN 3
\        ee:00       *ACCMOD MODE_A  %00=A  %01=B  %10=C  %11=D

;  \ init-fsmc


PB14 constant LCD-POWER-ENABLE-PIN
PE9  constant LCD-RESET-PIN
PB13 constant LCD-EXTENDED-COMMAND-PIN
PB10 constant LCD-TEARING-EFFECT-PIN

: init-lcd-gpio ( -- )

  \ Assign alternate function 12 ( $C ) to FSMC pins
  PA0 io-base GPIO.AFRL +  dup @ $000CCC00 or swap !  \ PA2 PA3 PA4
  PB0 io-base GPIO.AFRH +  dup @ $000C0000 or swap !  \ PB12
  PD0 io-base GPIO.AFRL +  dup @ $C0CC00CC or swap !  \ PD0 PD1  PD4  PD5  PD7
  PD0 io-base GPIO.AFRH +  dup @ $CC00CCC0 or swap !  \ PD9 PD10 PD11 PD14 PD15
  PE0 io-base GPIO.AFRH +  dup @ $CCCCCC00 or swap !  \ PE10 PE11 PE12 PE13 PE14 PE15
    
  OMODE-AF-PP OMODE-FAST +  PA0 %0000000000011100 io-modes!
  OMODE-AF-PP OMODE-FAST +  PB0 %0001000000000000 io-modes!
  OMODE-AF-PP OMODE-FAST +  PD0 %1100111010110011 io-modes!
  OMODE-AF-PP OMODE-FAST +  PE0 %1111110000000000 io-modes!
                               
           LCD-POWER-ENABLE-PIN ioc!
  OMODE-PP LCD-POWER-ENABLE-PIN io-mode!
           LCD-POWER-ENABLE-PIN ios!

           LCD-RESET-PIN ioc!
  OMODE-PP LCD-RESET-PIN io-mode!
           LCD-RESET-PIN ios!

           LCD-EXTENDED-COMMAND-PIN ioc!
  OMODE-PP LCD-EXTENDED-COMMAND-PIN io-mode!
           LCD-EXTENDED-COMMAND-PIN ios!

  IMODE-FLOAT LCD-TEARING-EFFECT-PIN io-mode!

  120 ms  \ LCD needs some time to get ready 

;  \ init-lcd-gpio


$60000000 constant LCD-COMMAND   \ A16 low 
$60020000 constant LCD-DATA      \ A16 high

: send-command ( command -- )  LCD-COMMAND h!  ;
: send-data    ( data -- )     LCD-DATA h!     ;
: receive-data ( -- data )     LCD-DATA @      ;


: init-lcd ( -- )

  init-fsmc
  init-lcd-gpio

  $01 send-command  \ Reset
  5 ms
  
  $11 send-command  \ SleepOut
  5 ms

  $3A send-command  \ PixelFormatSet
  $05 send-data
  
  $35 send-command  \ TearingEffectLineOn
  $00 send-data   
  
  $C6 send-command  \ FrameRateControl
  $1E send-data     \ 40 Hz frame rate

  $36 send-command  \ MemoryAccessControl
  $A0 send-data  \ Landscape
  
  $29 send-command  \ DisplayOn
  
;  \ init-lcd


\  LCD commands
\ --------------------------------------------------------------------------------------------------
\  $00  Nop
\  $01  Reset
\  $10  SleepIn
\  $11  SleepOut
\  $28  DisplayOff
\  $29  DisplayOn
\  $2A  ColumnAddressSet     (CASET)  4 parameters-8bit:  XstartHigh, XstartLow, XendHigh, XendLow
\  $2B  PageAddressSet       (RASET)  4 parameters-8bit:  YstartHigh, YstartLow, YendHigh, YendLow
\  $2C  MemoryWrite          (RAMWR)  n parameters-16bit: Pixelcolor
\  $2E  MemoryRead
\  $35  TearingEffectLineOn  (TEON)   1 parameter:  $00: V-blanking only   $01: V-blank and H-blank
\  $36  MemoryAccessControl  (MADCTL) 1 parameter:  $A0: Landscape   $00:Portrait
\  $3A  PixelFormatSet       (COLMOD) 1 parameter:  $05: 16bit/pixel
\  $C6  FrameRateControl


: set-area ( x y width height -- )  \ Sets a window in with pixels can be drawn

  rot
  ( x width height y )
           $2B  send-command   \ PageAddressSet
  dup 8 rshift  send-data  \ YstartHigh
  dup $FF and   send-data  \ YstartLow
  ( x width height y )
  + 1-
  ( x width height+y-1 )
  dup 8 rshift  send-data  \ YendHigh
      $FF and   send-data  \ YendLow
  
  ( x width )
  swap
  ( width x )  
           $2A  send-command   \ ColumnAddressSet
  dup 8 rshift  send-data  \ XstartHigh
  dup $FF and   send-data  \ XstartLow
  ( width x )
  + 1-
  ( width+x-1 )
  dup 8 rshift  send-data  \ XendHigh
      $FF and   send-data  \ XendLow
;


\ ----------------------------------------------------------
\ 'clear' and 'putpixel' are used by the graphics.txt code
\ ----------------------------------------------------------

: rgb ( r g b -- colour ) 31 255 */ >r 63 255 */ >r 31 255 */ 11 lshift r> 5 lshift or r> or 3-foldable ;

$0000 variable lcd-background  \ black
$FFFF variable lcd-foreground  \ white

: clear ( -- )  \ fills complete screen with 'lcd-background' - color
  0 0 320 240 set-area
  $2C send-command   \ MemoryWrite
  lcd-background @ 
  320 240 *  0
  do
      dup send-data  \ write pixel 
  loop
  drop
;


: putpixel ( x y -- )  \ set a pixel in display memory
  1 1 set-area  \ set a window 1 pixel by 1 pixel at position x/y
  $2C send-command   \ MemoryWrite
  lcd-foreground @  send-data  \ draw a pixel 
;

: clearpixel ( x y -- )  \ set a pixel in display memory
  1 1 set-area  \ set a window 1 pixel by 1 pixel at position x/y
  $2C send-command   \ MemoryWrite
  lcd-background @  send-data  \ draw a pixel 
;

: draw-npixels ( n -- )  \ Draws n pixels in 'lcd-foreground'-color to the screen.
                         \ Area must be set with 'set-area' beforehand.
  $2C send-command  \ MemoryWrite
  lcd-foreground @  \ get color
  swap
  ( color n ) 0
  do
      dup send-data  \ write pixel 
  loop
  drop
;


\ --------------------------------------------------
\  Playground
\ --------------------------------------------------

: test-lcd ( -- )  \ some basic tests
  
  init-delay  \ don't forget or you'll be sorry 
  
  init-backlight                  \ Backlight starts at 100%
  8 0 do decrease-backlight loop  \ reduce brightness to 50%
  
  init-lcd
  
  clear  \ paint a nice empty screen

  $FFFF lcd-foreground !  \ white 
  
  5 10 310 20 set-area   \ Window at 5/10 with size 310 by 20
  310 20 *  draw-npixels  \ Fill window with 'lcd-foreground' color
  

  \ draw red sawtooth
  $F800 lcd-foreground !  \ red 
  315 5
  do
      i  12 i $F and +  putpixel   
  loop


  \ draw colored checkerboard 
  $FFFF lcd-foreground !  \ white 
  20 0
  do
      30 0
      do
          i 10 * 10 +  j 10 * 40 +  7 7 set-area
          7 7 *  draw-npixels
      lcd-foreground @ 123 +  lcd-foreground !    
      loop
  loop


  \ back to white
  $FFFF lcd-foreground !  \ white 

;  \ test-lcd

\ eof


\ -------------------------------------------------------------
\  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 8x16 Bitmap font, taken from
\  http://v3.sk/~lkundrak/fonts/freebsd/fonts/iso-8x16
\  http://v3.sk/~lkundrak/fonts/freebsd/fonts/iso15-8x16
\ -------------------------------------------------------------

hex
create font

\ Unicode point, Bitmap Data                                               \ ISO8859-1, Name

0020 h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 32 Space SPACE
0021 h,  0000 h, 3C18 h, 3C3C h, 1818 h, 0018 h, 1818 h, 0000 h, 0000 h,   \ 33 !     EXCLAMATION MARK
0022 h,  6600 h, 6666 h, 0024 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 34 "     QUOTATION MARK
0023 h,  0000 h, 6C00 h, FE6C h, 6C6C h, FE6C h, 6C6C h, 0000 h, 0000 h,   \ 35 #     NUMBER SIGN
0024 h,  1818 h, C67C h, C0C2 h, 067C h, 8606 h, 7CC6 h, 1818 h, 0000 h,   \ 36 $     DOLLAR SIGN
0025 h,  0000 h, 0000 h, C6C2 h, 180C h, 6030 h, 86C6 h, 0000 h, 0000 h,   \ 37 %     PERCENT SIGN
0026 h,  0000 h, 6C38 h, 386C h, DC76 h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 38 &     AMPERSAND
0027 h,  3000 h, 3030 h, 0060 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 39 '     APOSTROPHE
0028 h,  0000 h, 180C h, 3030 h, 3030 h, 3030 h, 0C18 h, 0000 h, 0000 h,   \ 40 (     LEFT PARENTHESIS
0029 h,  0000 h, 1830 h, 0C0C h, 0C0C h, 0C0C h, 3018 h, 0000 h, 0000 h,   \ 41 )     RIGHT PARENTHESIS
002A h,  0000 h, 0000 h, 6600 h, FF3C h, 663C h, 0000 h, 0000 h, 0000 h,   \ 42 *     ASTERISK
002B h,  0000 h, 0000 h, 1800 h, 7E18 h, 1818 h, 0000 h, 0000 h, 0000 h,   \ 43 +     PLUS SIGN
002C h,  0000 h, 0000 h, 0000 h, 0000 h, 1800 h, 1818 h, 0030 h, 0000 h,   \ 44 ,     COMMA
002D h,  0000 h, 0000 h, 0000 h, FE00 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 45 -     HYPHEN-MINUS
002E h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 1818 h, 0000 h, 0000 h,   \ 46 .     FULL STOP
002F h,  0000 h, 0000 h, 0602 h, 180C h, 6030 h, 80C0 h, 0000 h, 0000 h,   \ 47 /     SOLIDUS
0030 h,  0000 h, 663C h, C3C3 h, DBDB h, C3C3 h, 3C66 h, 0000 h, 0000 h,   \ 48 0     DIGIT ZERO
0031 h,  0000 h, 3818 h, 1878 h, 1818 h, 1818 h, 7E18 h, 0000 h, 0000 h,   \ 49 1     DIGIT ONE
0032 h,  0000 h, C67C h, 0C06 h, 3018 h, C060 h, FEC6 h, 0000 h, 0000 h,   \ 50 2     DIGIT TWO
0033 h,  0000 h, C67C h, 0606 h, 063C h, 0606 h, 7CC6 h, 0000 h, 0000 h,   \ 51 3     DIGIT THREE
0034 h,  0000 h, 1C0C h, 6C3C h, FECC h, 0C0C h, 1E0C h, 0000 h, 0000 h,   \ 52 4     DIGIT FOUR
0035 h,  0000 h, C0FE h, C0C0 h, 06FC h, 0606 h, 7CC6 h, 0000 h, 0000 h,   \ 53 5     DIGIT FIVE
0036 h,  0000 h, 6038 h, C0C0 h, C6FC h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 54 6     DIGIT SIX
0037 h,  0000 h, C6FE h, 0606 h, 180C h, 3030 h, 3030 h, 0000 h, 0000 h,   \ 55 7     DIGIT SEVEN
0038 h,  0000 h, C67C h, C6C6 h, C67C h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 56 8     DIGIT EIGHT
0039 h,  0000 h, C67C h, C6C6 h, 067E h, 0606 h, 780C h, 0000 h, 0000 h,   \ 57 9     DIGIT NINE
003A h,  0000 h, 0000 h, 1818 h, 0000 h, 1800 h, 0018 h, 0000 h, 0000 h,   \ 58 :     COLON
003B h,  0000 h, 0000 h, 1818 h, 0000 h, 1800 h, 3018 h, 0000 h, 0000 h,   \ 59 ;     SEMICOLON
003C h,  0000 h, 0600 h, 180C h, 6030 h, 1830 h, 060C h, 0000 h, 0000 h,   \ 60 <     LESS-THAN SIGN
003D h,  0000 h, 0000 h, 7E00 h, 0000 h, 007E h, 0000 h, 0000 h, 0000 h,   \ 61 =     EQUALS SIGN
003E h,  0000 h, 6000 h, 1830 h, 060C h, 180C h, 6030 h, 0000 h, 0000 h,   \ 62 >     GREATER-THAN SIGN
003F h,  0000 h, C67C h, 0CC6 h, 1818 h, 0018 h, 1818 h, 0000 h, 0000 h,   \ 63 ?     QUESTION MARK

0040 h,  0000 h, 7C00 h, C6C6 h, DEDE h, DCDE h, 7CC0 h, 0000 h, 0000 h,   \ 64 @     COMMERCIAL AT
0041 h,  0000 h, 3810 h, C66C h, FEC6 h, C6C6 h, C6C6 h, 0000 h, 0000 h,   \ 65 A     LATIN CAPITAL LETTER A
0042 h,  0000 h, 66FC h, 6666 h, 667C h, 6666 h, FC66 h, 0000 h, 0000 h,   \ 66 B     LATIN CAPITAL LETTER B
0043 h,  0000 h, 663C h, C0C2 h, C0C0 h, C2C0 h, 3C66 h, 0000 h, 0000 h,   \ 67 C     LATIN CAPITAL LETTER C
0044 h,  0000 h, 6CF8 h, 6666 h, 6666 h, 6666 h, F86C h, 0000 h, 0000 h,   \ 68 D     LATIN CAPITAL LETTER D
0045 h,  0000 h, 66FE h, 6862 h, 6878 h, 6260 h, FE66 h, 0000 h, 0000 h,   \ 69 E     LATIN CAPITAL LETTER E
0046 h,  0000 h, 66FE h, 6862 h, 6878 h, 6060 h, F060 h, 0000 h, 0000 h,   \ 70 F     LATIN CAPITAL LETTER F
0047 h,  0000 h, 663C h, C0C2 h, DEC0 h, C6C6 h, 3A66 h, 0000 h, 0000 h,   \ 71 G     LATIN CAPITAL LETTER G
0048 h,  0000 h, C6C6 h, C6C6 h, C6FE h, C6C6 h, C6C6 h, 0000 h, 0000 h,   \ 72 H     LATIN CAPITAL LETTER H
0049 h,  0000 h, 183C h, 1818 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 73 I     LATIN CAPITAL LETTER I
004A h,  0000 h, 0C1E h, 0C0C h, 0C0C h, CCCC h, 78CC h, 0000 h, 0000 h,   \ 74 J     LATIN CAPITAL LETTER J
004B h,  0000 h, 66E6 h, 6C66 h, 7878 h, 666C h, E666 h, 0000 h, 0000 h,   \ 75 K     LATIN CAPITAL LETTER K
004C h,  0000 h, 60F0 h, 6060 h, 6060 h, 6260 h, FE66 h, 0000 h, 0000 h,   \ 76 L     LATIN CAPITAL LETTER L
004D h,  0000 h, E7C3 h, FFFF h, C3DB h, C3C3 h, C3C3 h, 0000 h, 0000 h,   \ 77 M     LATIN CAPITAL LETTER M
004E h,  0000 h, E6C6 h, FEF6 h, CEDE h, C6C6 h, C6C6 h, 0000 h, 0000 h,   \ 78 N     LATIN CAPITAL LETTER N
004F h,  0000 h, C67C h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 79 O     LATIN CAPITAL LETTER O
0050 h,  0000 h, 66FC h, 6666 h, 607C h, 6060 h, F060 h, 0000 h, 0000 h,   \ 80 P     LATIN CAPITAL LETTER P
0051 h,  0000 h, C67C h, C6C6 h, C6C6 h, D6C6 h, 7CDE h, 0E0C h, 0000 h,   \ 81 Q     LATIN CAPITAL LETTER Q
0052 h,  0000 h, 66FC h, 6666 h, 6C7C h, 6666 h, E666 h, 0000 h, 0000 h,   \ 82 R     LATIN CAPITAL LETTER R
0053 h,  0000 h, C67C h, 60C6 h, 0C38 h, C606 h, 7CC6 h, 0000 h, 0000 h,   \ 83 S     LATIN CAPITAL LETTER S
0054 h,  0000 h, DBFF h, 1899 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 84 T     LATIN CAPITAL LETTER T
0055 h,  0000 h, C6C6 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 85 U     LATIN CAPITAL LETTER U
0056 h,  0000 h, C3C3 h, C3C3 h, C3C3 h, 66C3 h, 183C h, 0000 h, 0000 h,   \ 86 V     LATIN CAPITAL LETTER V
0057 h,  0000 h, C3C3 h, C3C3 h, DBC3 h, FFDB h, 6666 h, 0000 h, 0000 h,   \ 87 W     LATIN CAPITAL LETTER W
0058 h,  0000 h, C3C3 h, 3C66 h, 1818 h, 663C h, C3C3 h, 0000 h, 0000 h,   \ 88 X     LATIN CAPITAL LETTER X
0059 h,  0000 h, C3C3 h, 66C3 h, 183C h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 89 Y     LATIN CAPITAL LETTER Y
005A h,  0000 h, C3FF h, 0C86 h, 3018 h, C160 h, FFC3 h, 0000 h, 0000 h,   \ 90 Z     LATIN CAPITAL LETTER Z
005B h,  0000 h, 303C h, 3030 h, 3030 h, 3030 h, 3C30 h, 0000 h, 0000 h,   \ 91 [     LEFT SQUARE BRACKET
005C h,  0000 h, 8000 h, E0C0 h, 3870 h, 0E1C h, 0206 h, 0000 h, 0000 h,   \ 92 \     REVERSE SOLIDUS
005D h,  0000 h, 0C3C h, 0C0C h, 0C0C h, 0C0C h, 3C0C h, 0000 h, 0000 h,   \ 93 ]     RIGHT SQUARE BRACKET
005E h,  3810 h, C66C h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 94 ^     CIRCUMFLEX ACCENT
005F h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, FF00 h, 0000 h,   \ 95 _     LOW LINE

0060 h,  3030 h, 0018 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 96 `     GRAVE ACCENT
0061 h,  0000 h, 0000 h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 97 a     LATIN SMALL LETTER A
0062 h,  0000 h, 60E0 h, 7860 h, 666C h, 6666 h, 7C66 h, 0000 h, 0000 h,   \ 98 b     LATIN SMALL LETTER B
0063 h,  0000 h, 0000 h, 7C00 h, C0C6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 99 c     LATIN SMALL LETTER C
0064 h,  0000 h, 0C1C h, 3C0C h, CC6C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 100 d    LATIN SMALL LETTER D
0065 h,  0000 h, 0000 h, 7C00 h, FEC6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 101 e    LATIN SMALL LETTER E
0066 h,  0000 h, 6C38 h, 6064 h, 60F0 h, 6060 h, F060 h, 0000 h, 0000 h,   \ 102 f    LATIN SMALL LETTER F
0067 h,  0000 h, 0000 h, 7600 h, CCCC h, CCCC h, 7CCC h, CC0C h, 0078 h,   \ 103 g    LATIN SMALL LETTER G
0068 h,  0000 h, 60E0 h, 6C60 h, 6676 h, 6666 h, E666 h, 0000 h, 0000 h,   \ 104 h    LATIN SMALL LETTER H
0069 h,  0000 h, 1818 h, 3800 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 105 i    LATIN SMALL LETTER I
006A h,  0000 h, 0606 h, 0E00 h, 0606 h, 0606 h, 0606 h, 6666 h, 003C h,   \ 106 j    LATIN SMALL LETTER J
006B h,  0000 h, 60E0 h, 6660 h, 786C h, 6C78 h, E666 h, 0000 h, 0000 h,   \ 107 k    LATIN SMALL LETTER K
006C h,  0000 h, 1838 h, 1818 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 108 l    LATIN SMALL LETTER L
006D h,  0000 h, 0000 h, E600 h, DBFF h, DBDB h, DBDB h, 0000 h, 0000 h,   \ 109 m    LATIN SMALL LETTER M
006E h,  0000 h, 0000 h, DC00 h, 6666 h, 6666 h, 6666 h, 0000 h, 0000 h,   \ 110 n    LATIN SMALL LETTER N
006F h,  0000 h, 0000 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 111 o    LATIN SMALL LETTER O
0070 h,  0000 h, 0000 h, DC00 h, 6666 h, 6666 h, 7C66 h, 6060 h, 00F0 h,   \ 112 p    LATIN SMALL LETTER P
0071 h,  0000 h, 0000 h, 7600 h, CCCC h, CCCC h, 7CCC h, 0C0C h, 001E h,   \ 113 q    LATIN SMALL LETTER Q
0072 h,  0000 h, 0000 h, DC00 h, 6676 h, 6060 h, F060 h, 0000 h, 0000 h,   \ 114 r    LATIN SMALL LETTER R
0073 h,  0000 h, 0000 h, 7C00 h, 60C6 h, 0C38 h, 7CC6 h, 0000 h, 0000 h,   \ 115 s    LATIN SMALL LETTER S
0074 h,  0000 h, 3010 h, FC30 h, 3030 h, 3030 h, 1C36 h, 0000 h, 0000 h,   \ 116 t    LATIN SMALL LETTER T
0075 h,  0000 h, 0000 h, CC00 h, CCCC h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 117 u    LATIN SMALL LETTER U
0076 h,  0000 h, 0000 h, C300 h, C3C3 h, 66C3 h, 183C h, 0000 h, 0000 h,   \ 118 v    LATIN SMALL LETTER V
0077 h,  0000 h, 0000 h, C300 h, C3C3 h, DBDB h, 66FF h, 0000 h, 0000 h,   \ 119 w    LATIN SMALL LETTER W
0078 h,  0000 h, 0000 h, C300 h, 3C66 h, 3C18 h, C366 h, 0000 h, 0000 h,   \ 120 x    LATIN SMALL LETTER X
0079 h,  0000 h, 0000 h, C600 h, C6C6 h, C6C6 h, 7EC6 h, 0C06 h, 00F8 h,   \ 121 y    LATIN SMALL LETTER Y
007A h,  0000 h, 0000 h, FE00 h, 18CC h, 6030 h, FEC6 h, 0000 h, 0000 h,   \ 122 z    LATIN SMALL LETTER Z
007B h,  0000 h, 180E h, 1818 h, 1870 h, 1818 h, 0E18 h, 0000 h, 0000 h,   \ 123 {    LEFT CURLY BRACKET
007C h,  0000 h, 1818 h, 1818 h, 1818 h, 1818 h, 1818 h, 0000 h, 0000 h,   \ 124 |    VERTICAL LINE
007D h,  0000 h, 1870 h, 1818 h, 180E h, 1818 h, 7018 h, 0000 h, 0000 h,   \ 125 }    RIGHT CURLY BRACKET
007E h,  0000 h, DC76 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 126 ~    TILDE
007F h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 127 Del  DELETE

00A0 h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 160      NO-BREAK SPACE
00A1 h,  0000 h, 1818 h, 1800 h, 1818 h, 3C3C h, 183C h, 0000 h, 0000 h,   \ 161      INVERTED EXCLAMATION MARK
00A2 h,  1800 h, 7E18 h, C0C3 h, C0C0 h, 7EC3 h, 1818 h, 0000 h, 0000 h,   \ 162      CENT SIGN
00A3 h,  3800 h, 646C h, F060 h, 6060 h, 6060 h, FCE6 h, 0000 h, 0000 h,   \ 163      POUND SIGN
00A4 h,  0000 h, 8200 h, 7CC6 h, C6C6 h, C6C6 h, C67C h, 0082 h, 0000 h,   \ 164      CURRENCY SIGN
00A5 h,  0000 h, 66C3 h, 183C h, 18FF h, 18FF h, 1818 h, 0000 h, 0000 h,   \ 165      YEN SIGN
00A6 h,  0000 h, 1818 h, 1818 h, 1800 h, 1818 h, 1818 h, 0000 h, 0000 h,   \ 166      BROKEN BAR
00A7 h,  7C00 h, 60C6 h, 6C38 h, C6C6 h, 386C h, C60C h, 007C h, 0000 h,   \ 167      SECTION SIGN
00A8 h,  C600 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 168      DIAERESIS
00A9 h,  0000 h, C67C h, BA82 h, A2A2 h, 82BA h, 7CC6 h, 0000 h, 0000 h,   \ 169      COPYRIGHT SIGN
00AA h,  7000 h, 7818 h, 78C8 h, F800 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 170      FEMININE ORDINAL INDICATOR
00AB h,  0000 h, 0000 h, 3600 h, D86C h, 366C h, 0000 h, 0000 h, 0000 h,   \ 171      LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
00AC h,  0000 h, 0000 h, 0000 h, 06FE h, 0606 h, 0006 h, 0000 h, 0000 h,   \ 172      NOT SIGN
00AD h,  0000 h, 0000 h, 0000 h, 7C00 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 173      SOFT HYPHEN
00AE h,  0000 h, C67C h, BA82 h, B2AA h, 82AA h, 7CC6 h, 0000 h, 0000 h,   \ 174      REGISTERED SIGN
00AF h,  FE00 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 175      MACRON
00B0 h,  3800 h, 6C6C h, 0038 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 176      DEGREE SIGN
00B1 h,  0000 h, 0000 h, 1818 h, 187E h, 0018 h, 7E00 h, 0000 h, 0000 h,   \ 177      PLUS-MINUS SIGN
00B2 h,  7000 h, 30D8 h, C860 h, 00F8 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 178      SUPERSCRIPT TWO
00B3 h,  F800 h, 3018 h, D818 h, 0070 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 179      SUPERSCRIPT THREE
00B4 h,  3018 h, 0060 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 180      ACUTE ACCENT
00B5 h,  0000 h, 0000 h, 6666 h, 6666 h, 7E66 h, 6063 h, 00C0 h, 0000 h,   \ 181      MICRO SIGN
00B6 h,  0000 h, DB7F h, DBDB h, 1B7B h, 1B1B h, 1B1B h, 0000 h, 0000 h,   \ 182      PILCROW SIGN
00B7 h,  0000 h, 0000 h, 0000 h, 1800 h, 0018 h, 0000 h, 0000 h, 0000 h,   \ 183      MIDDLE DOT
00B8 h,  0000 h, 0000 h, 0000 h, 0000 h, 0000 h, 0C18 h, 3C06 h, 0000 h,   \ 184      CEDILLA
00B9 h,  6000 h, 60E0 h, 6060 h, 00F0 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 185      SUPERSCRIPT ONE
00BA h,  7000 h, 88D8 h, 70D8 h, F800 h, 0000 h, 0000 h, 0000 h, 0000 h,   \ 186      MASCULINE ORDINAL INDICATOR
00BB h,  0000 h, 0000 h, D800 h, 366C h, D86C h, 0000 h, 0000 h, 0000 h,   \ 187      RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
00BC h,  C000 h, C2C0 h, CCC6 h, 3018 h, CE66 h, 3E96 h, 0606 h, 0000 h,   \ 188      VULGAR FRACTION ONE QUARTER
00BD h,  C000 h, C2C0 h, CCC6 h, 3018 h, CE60 h, 069B h, 1F0C h, 0000 h,   \ 189      VULGAR FRACTION ONE HALF
00BE h,  F000 h, 7230 h, EC36 h, 3018 h, CE66 h, 3E96 h, 0606 h, 0000 h,   \ 190      VULGAR FRACTION THREE QUARTERS
00BF h,  0000 h, 3030 h, 3000 h, 6030 h, C6C0 h, 7CC6 h, 0000 h, 0000 h,   \ 191      INVERTED QUESTION MARK

00C0 h,  3060 h, 0018 h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 192      LATIN CAPITAL LETTER A WITH GRAVE
00C1 h,  180C h, 0030 h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 193      LATIN CAPITAL LETTER A WITH ACUTE
00C2 h,  3810 h, 006C h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 194      LATIN CAPITAL LETTER A WITH CIRCUMFLEX
00C3 h,  7600 h, 00DC h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 195      LATIN CAPITAL LETTER A WITH TILDE
00C4 h,  C600 h, 1000 h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 196      LATIN CAPITAL LETTER A WITH DIAERESIS
00C5 h,  6C38 h, 0038 h, 6C38 h, C6C6 h, C6FE h, C6C6 h, 0000 h, 0000 h,   \ 197      LATIN CAPITAL LETTER A WITH RING ABOVE
00C6 h,  0000 h, 6C3E h, CCCC h, CCFE h, CCCC h, CECC h, 0000 h, 0000 h,   \ 198      LATIN CAPITAL LETTER AE
00C7 h,  0000 h, 663C h, C0C2 h, C0C0 h, 66C2 h, 0C3C h, 7C06 h, 0000 h,   \ 199      LATIN CAPITAL LETTER C WITH CEDILLA
00C8 h,  1830 h, 000C h, 66FE h, 7C60 h, 6060 h, FE66 h, 0000 h, 0000 h,   \ 200      LATIN CAPITAL LETTER E WITH GRAVE
00C9 h,  3018 h, 0060 h, 66FE h, 7C60 h, 6060 h, FE66 h, 0000 h, 0000 h,   \ 201      LATIN CAPITAL LETTER E WITH ACUTE
00CA h,  3810 h, 006C h, 66FE h, 7C60 h, 6060 h, FE66 h, 0000 h, 0000 h,   \ 202      LATIN CAPITAL LETTER E WITH CIRCUMFLEX
00CB h,  C600 h, FE00 h, 6066 h, 7C60 h, 6060 h, FE66 h, 0000 h, 0000 h,   \ 203      LATIN CAPITAL LETTER E WITH DIAERESIS
00CC h,  1830 h, 000C h, 183C h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 204      LATIN CAPITAL LETTER I WITH GRAVE
00CD h,  180C h, 0030 h, 183C h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 205      LATIN CAPITAL LETTER I WITH ACUTE
00CE h,  3C18 h, 0066 h, 183C h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 206      LATIN CAPITAL LETTER I WITH CIRCUMFLEX
00CF h,  6600 h, 3C00 h, 1818 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 207      LATIN CAPITAL LETTER I WITH DIAERESIS
00D0 h,  0000 h, 6C78 h, 6666 h, F666 h, 6666 h, 786C h, 0000 h, 0000 h,   \ 208      LATIN CAPITAL LETTER ETH (Icelandic)
00D1 h,  DC76 h, C600 h, F6E6 h, DEFE h, C6CE h, C6C6 h, 0000 h, 0000 h,   \ 209      LATIN CAPITAL LETTER N WITH TILDE
00D2 h,  3060 h, 0018 h, C67C h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 210      LATIN CAPITAL LETTER O WITH GRAVE
00D3 h,  180C h, 0030 h, C67C h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 211      LATIN CAPITAL LETTER O WITH ACUTE
00D4 h,  3810 h, 006C h, C67C h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 212      LATIN CAPITAL LETTER O WITH CIRCUMFLEX
00D5 h,  DC76 h, 7C00 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 213      LATIN CAPITAL LETTER O WITH TILDE
00D6 h,  C600 h, 7C00 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 214      LATIN CAPITAL LETTER O WITH DIAERESIS
00D7 h,  0000 h, 0000 h, 6CC6 h, 1038 h, 6C38 h, 00C6 h, 0000 h, 0000 h,   \ 215      MULTIPLICATION SIGN
00D8 h,  0602 h, CE7C h, DECE h, D6D6 h, E6F6 h, 7CE6 h, 80C0 h, 0000 h,   \ 216      LATIN CAPITAL LETTER O WITH STROKE
00D9 h,  3060 h, 0018 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 217      LATIN CAPITAL LETTER U WITH GRAVE
00DA h,  180C h, 0030 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 218      LATIN CAPITAL LETTER U WITH ACUTE
00DB h,  3810 h, 006C h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 219      LATIN CAPITAL LETTER U WITH CIRCUMFLEX
00DC h,  C600 h, C600 h, C6C6 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 220      LATIN CAPITAL LETTER U WITH DIAERESIS
00DD h,  180C h, 0030 h, C3C3 h, 3C66 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 221      LATIN CAPITAL LETTER Y WITH ACUTE
00DE h,  60F0 h, 667C h, 6666 h, 607C h, 6060 h, F060 h, 0000 h, 0000 h,   \ 222      LATIN CAPITAL LETTER THORN (Icelandic)
00DF h,  0000 h, 6C38 h, CEC6 h, D8DC h, C6CC h, DCD6 h, 80C0 h, 0000 h,   \ 223      LATIN SMALL LETTER SHARP S (German)

00E0 h,  6000 h, 1830 h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 224      LATIN SMALL LETTER A WITH GRAVE
00E1 h,  1800 h, 6030 h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 225      LATIN SMALL LETTER A WITH ACUTE
00E2 h,  1000 h, 6C38 h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 226      LATIN SMALL LETTER A WITH CIRCUMFLEX
00E3 h,  0000 h, DC76 h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 227      LATIN SMALL LETTER A WITH TILDE
00E4 h,  0000 h, 00CC h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 228      LATIN SMALL LETTER A WITH DIAERESIS
00E5 h,  3800 h, 386C h, 7800 h, 7C0C h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 229      LATIN SMALL LETTER A WITH RING ABOVE
00E6 h,  0000 h, 0000 h, 6E00 h, 1B3B h, D87E h, 77DC h, 0000 h, 0000 h,   \ 230      LATIN SMALL LETTER AE
00E7 h,  0000 h, 0000 h, 663C h, 6060 h, 3C66 h, 060C h, 003C h, 0000 h,   \ 231      LATIN SMALL LETTER C WITH CEDILLA
00E8 h,  6000 h, 1830 h, 7C00 h, FEC6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 232      LATIN SMALL LETTER E WITH GRAVE
00E9 h,  0C00 h, 3018 h, 7C00 h, FEC6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 233      LATIN SMALL LETTER E WITH ACUTE
00EA h,  1000 h, 6C38 h, 7C00 h, FEC6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 234      LATIN SMALL LETTER E WITH CIRCUMFLEX
00EB h,  0000 h, 00C6 h, 7C00 h, FEC6 h, C0C0 h, 7CC6 h, 0000 h, 0000 h,   \ 235      LATIN SMALL LETTER E WITH DIAERESIS
00EC h,  6000 h, 1830 h, 3800 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 236      LATIN SMALL LETTER I WITH GRAVE
00ED h,  0600 h, 180C h, 3800 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 237      LATIN SMALL LETTER I WITH ACUTE
00EE h,  1800 h, 663C h, 3800 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 238      LATIN SMALL LETTER I WITH CIRCUMFLEX
00EF h,  0000 h, 0066 h, 3800 h, 1818 h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 239      LATIN SMALL LETTER I WITH DIAERESIS
00F0 h,  6C00 h, 3838 h, 0C6C h, 6C3C h, CCCC h, 78CC h, 0000 h, 0000 h,   \ 240      LATIN SMALL LETTER ETH (Icelandic)
00F1 h,  0000 h, DC76 h, DC00 h, 6666 h, 6666 h, 6666 h, 0000 h, 0000 h,   \ 241      LATIN SMALL LETTER N WITH TILDE
00F2 h,  6000 h, 1830 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 242      LATIN SMALL LETTER O WITH GRAVE
00F3 h,  1800 h, 6030 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 243      LATIN SMALL LETTER O WITH ACUTE
00F4 h,  1000 h, 6C38 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 244      LATIN SMALL LETTER O WITH CIRCUMFLEX
00F5 h,  0000 h, DC76 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 245      LATIN SMALL LETTER O WITH TILDE
00F6 h,  0000 h, 00C6 h, 7C00 h, C6C6 h, C6C6 h, 7CC6 h, 0000 h, 0000 h,   \ 246      LATIN SMALL LETTER O WITH DIAERESIS
00F7 h,  0000 h, 0000 h, 1818 h, 7E00 h, 1800 h, 0018 h, 0000 h, 0000 h,   \ 247      DIVISION SIGN
00F8 h,  0000 h, 0200 h, 7C06 h, DECE h, F6D6 h, 7CE6 h, 80C0 h, 0000 h,   \ 248      LATIN SMALL LETTER O WITH STROKE
00F9 h,  6000 h, 1830 h, CC00 h, CCCC h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 249      LATIN SMALL LETTER U WITH GRAVE
00FA h,  1800 h, 6030 h, CC00 h, CCCC h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 250      LATIN SMALL LETTER U WITH ACUTE
00FB h,  3000 h, CC78 h, CC00 h, CCCC h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 251      LATIN SMALL LETTER U WITH CIRCUMFLEX
00FC h,  0000 h, 00CC h, CC00 h, CCCC h, CCCC h, 76CC h, 0000 h, 0000 h,   \ 252      LATIN SMALL LETTER U WITH DIAERESIS
00FD h,  1800 h, 6030 h, C600 h, C6C6 h, C6C6 h, 7EC6 h, 0C06 h, 00F8 h,   \ 253      LATIN SMALL LETTER Y WITH ACUTE
00FE h,  0000 h, F000 h, 7C60 h, 6666 h, 6666 h, 7C66 h, 6060 h, 00F0 h,   \ 254      LATIN SMALL LETTER THORN (Icelandic)
00FF h,  0000 h, 6666 h, EE00 h, 6666 h, 6666 h, 3E66 h, 0C06 h, 0038 h,   \ 255      LATIN SMALL LETTER Y WITH DIAERESIS


\ Unicode point, Bitmap Data               \ ISO8859-15, Name

20AC h,  0000 h, 311E h, 6060 h, 60FE h, 60FC h, 1E31 h, 0000 h, 0000 h,   \ 164      EURO SIGN
0160 h,  386C h, 0010 h, C67C h, 3060 h, 0C18 h, 7CC6 h, 0000 h, 0000 h,   \ 166      LATIN CAPITAL LETTER S WITH CARON
0161 h,  6C00 h, 1038 h, 7C00 h, 60C6 h, 0C38 h, 7CC6 h, 0000 h, 0000 h,   \ 168      LATIN SMALL LETTER S WITH CARON
017D h,  386C h, 0010 h, C6FE h, 180C h, 6030 h, FEC6 h, 0000 h, 0000 h,   \ 180      LATIN CAPITAL LETTER Z WITH CARON
017E h,  6C00 h, 1038 h, FE00 h, 18CC h, 6030 h, FEC6 h, 0000 h, 0000 h,   \ 184      LATIN SMALL LETTER Z WITH CARON
0152 h,  0000 h, CC7E h, CCCC h, CCCE h, CCCC h, 7ECC h, 0000 h, 0000 h,   \ 188      LATIN CAPITAL LIGATURE OE
0153 h,  0000 h, 0000 h, 6E00 h, DBDB h, D8DE h, 67DC h, 0000 h, 0000 h,   \ 189      LATIN SMALL LIGATURE OE
0178 h,  C300 h, C300 h, 66C3 h, 183C h, 1818 h, 3C18 h, 0000 h, 0000 h,   \ 190      LATIN CAPITAL LETTER Y WITH DIAERESIS


0000 h,  0000 h, 0000 h, 3810 h, C66C h, FEC6 h, 0000 h, 0000 h, 0000 h,   \ End of font marker, replacement glyph.

align decimal


: unicode>bitmap ( x -- c-addr ) \ Translates Unicode character to address of 8x8 bitmap.

  font ( x addr )
  begin
    2dup h@ = if nip 2 + exit then \ Character found, skip character number, give back bitmap data
  dup h@ while \ As long as there are more characters left in the glyph collection...
    18 + \ Not this one, skip it and its bitmap
  repeat

  nip 2 + \ Character not found within available collection of glyphs. Display replacement.

1-foldable ;

\ -------------------------------------------------------------
\  Write an Unicode character with 8x16 bitmap font
\ -------------------------------------------------------------

0 variable font-x   0 variable font-y

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

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

: drawunicode ( x -- ) unicode>bitmap drawcharacterbitmap ;

\ -------------------------------------------------------------
\  Unicode UTF-8 encoding decoder
\ -------------------------------------------------------------

0 variable utf8collection
0 variable utf8continuation

: utf8-character-length ( c -- c u )
  dup %11000000 and %11000000 = if dup 24 lshift not clz else 1 then ;

: drawcharacter ( c -- ) \ Handles a stream of UTF-8 bytes and translates this into Unicode letters.

  dup 10 = if drop 0 font-x ! 16 font-y +! exit then \ Special handling for line feed.

  utf8continuation @
  if   \ Continue to receive an extended character into buffer

    %00111111 and utf8collection @ 6 lshift or utf8collection !  \ Six more bits
    -1 utf8continuation +!                                       \ One less continuation byte to expect
    utf8continuation @ 0= if utf8collection @ drawunicode then   \ Draw character if complete encoding was buffered.

  else \ Begin of a new character

    utf8-character-length 1- ?dup

    if \ Start of a new character or a sequence
      dup utf8continuation !
      25 + tuck lshift swap rshift \ Remove the length encoding by shifting it out of the register temporarily
      utf8collection !
    else \ One byte characters are classic 7 bit ASCII and can be drawn immediately
      drawunicode
    then

  then
;

\ -------------------------------------------------------------
\  Write a string and split into individual characters
\ -------------------------------------------------------------

: 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
    get-first-char
    drawcharacter
    cut-first-char
  repeat
  2drop
;

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

: demo ( -- )
  clear
  50 14 32 12 ellipse
  50 14 34 14 ellipse
  s" Mecrisp" 22 7 drawstring
  2 4 12 24 line
  4 4 14 24 line
;
\ Memory block editor for Mecrisp-Stellaris, Copyright (C) 2014  Matthias Koch
\ This is free software under GNU General Public License v3.

( Terminal handling routines - specials to interface with LCD display. )

: at-xy ( column row -- ) 16 * font-y ! 8 * font-x ! ; \ Grid to pixel coordinates for a 8x16 font

( Editor variables and settings )

38 constant columns  ( 64x16 is most common, 40x25 is found sometimes )
12 constant rows     ( You can set something like 128x1 for line editing )

0 variable editor-buffer
char i variable mode
0 variable x
0 variable y

( Small drawing helpers )

: border ( -- )
  0 1 at-xy
  columns 2+ 0 do [char] - emit loop cr
  rows 0 do ." |" columns spaces ." |" cr loop
  columns 2+ 0 do [char] - emit loop cr ;

: mode. columns 1- 0 at-xy mode @ emit ;
: memory. 0 0 at-xy ." Memory at: " editor-buffer @ hex. ;
: header ( -- ) memory. mode. ;

( Buffer manipulation helpers )

: where ( x y -- c-addr ) columns * + editor-buffer @ + ;
: where-cursor ( -- c-addr ) x @ y @ where ; \ Find buffer location for given x,y
: eol ( -- c-addr ) columns 1- y @ where ;

( Unicode helpers )

: count-%10-addr ( addr -- u ) \ How many %10... are in this line ?
  0 columns 0 do  over i + c@ %11000000 and %10000000 = if 1+ then loop nip ;

: count-%10-to-cursor ( -- u ) \ How many %10... are there up to the cursor position ?
  0 x @ 1+ 0 do  i y @ where c@ %11000000 and %10000000 = if 1+ then loop ;

: utf8-character-length ( c -- c u )
  dup %11000000 and %11000000 = if dup 24 lshift not clz else 1 then ;

: utf8-eol? ( -- ? ) x @ where-cursor c@ utf8-character-length nip +  columns >= ;

( Line writing helpers )

: row ( addr -- addr+columns ) dup columns type dup count-%10-addr spaces columns + ;
: character-x ( -- u ) x @ count-%10-to-cursor - ;
: cursor ( -- ) character-x 1+ y @ 2 + at-xy ;
: redraw-line ( -- ) 1 y @ 2+ at-xy 0 y @ where row drop cursor ;

( Editor Movements )

: boundX ( -- ) x @ 0 max x ! ; \ Cannot simply use columns-1 as bound for UTF-8
: boundY ( -- ) y @ 0 max rows 1- min y ! ;
: bounds ( -- ) boundX boundY ;
: left   ( -- ) begin -1 x +!  where-cursor c@ %11000000 and %10000000 <> until bounds ;
: right  ( -- ) utf8-eol? not if x @ where-cursor c@ utf8-character-length nip + x ! then ;
: up     ( -- ) character-x   -1 y +! bounds 0 x !   0 ?do right loop  ;
: down   ( -- ) character-x    1 y +! bounds 0 x !   0 ?do right loop  ;
: flushleft ( -- ) 0 x ! ;

: utf8-eol  ( -- ) flushleft begin right utf8-eol? until ;
: gotoeol   ( -- ) utf8-eol begin where-cursor c@ 32 = x @ 0 <> and while left repeat
                   where-cursor c@ 32 <> if right then ;

: previousline ( -- ) y @ 0<> if up utf8-eol then ;
: nextline ( -- ) y @ rows 1- < if flushleft down then ;
: next ( -- ) utf8-eol? if redraw-line nextline else right then ;

: left-wrap  ( -- ) x @ 0 = if previousline else left then ;
: right-wrap ( -- ) utf8-eol? if nextline else right then ;

( Editor Insert/Replace Text )

: openright ( -- )
  \ If there is an Unicode continuation byte, replace the complete trailing Unicode bytes sequence with spaces.
  columns 1- y @ where
  dup c@ %11000000 and %10000000 <>
  if drop
  else
    ( addr ) \ Save this and move address backward until the %11... byte appears.
    begin 32 over c! 1- dup c@ %11000000 and %11000000 = until 32 swap c!
 then
 where-cursor dup 1+ columns 1- x @ - move ;  \ Move the rest of the line right one character

: inserting? ( -- ? ) mode @ [char] i = ;
: togglemode ( -- ) inserting? if [char] o mode ! else [char] i mode ! then mode. ;

: character ( c -- )
    \ Drop Byte sequence if this is start of an Unicode character that won't fit anymore at current position.
  utf8-character-length x @ + columns 1+ >= if utf8-character-length 1- 0 ?do key drop loop drop exit then
    \ Open a gap for the whole Unicode byte sequence
  inserting? if utf8-character-length 0 do openRight loop then
    \ Insert the character or the complete Unicode byte sequence
  utf8-character-length 0 do i 0<> if key then where-cursor i + c! loop
  next ;

( Editor Backspace/Delete )

: del ( -- ) where-cursor dup 1+ swap columns 1- x @ - move ;
: delete ( -- ) where-cursor c@ utf8-character-length nip 0 do del 32 eol c! loop ;
: backspace ( -- ) x @ 0 > if left delete then ;

( Editor Return )

: return ( -- ) y @ rows 1- <> if ( inserting? if splitline then ) nextline cursor then ;

( Editor )

: editor ( Address -- )

  init-delay  \ don't forget or you'll be sorry 
  
  init-backlight                  \ Backlight starts at 100%
  8 0 do decrease-backlight loop  \ reduce brightness to 50%
  
  init-lcd

  keyboard-into-terminal

  ['] drawcharacter hook-emit !   \ Relay output of emit to LCD
    0   0 64 rgb lcd-background ! \ Dark blue background
  255 200  0 rgb lcd-foreground ! \ Yellow font

  editor-buffer !                   \ Save address to edit
  clear header border               \ Draw outline
  rows 0 do i y ! redraw-line loop  \ Print contents of the buffer
  0 x ! 0 y ! cursor                \ Show cursor and start to edit

  begin
    key
    dup 32 >=
    if character redraw-line
    else
      case \ Handle control characters
         8 of backspace redraw-line endof
         9 of 8 0 do right loop cursor endof \ Tab
        10 of return endof
        13 of return endof
        17 of 0 rows 3 + at-xy rdrop ['] serial-emit hook-emit ! exit endof \ Ctrl+Q: Set cursor at the end of the editor window on exit.
        27 of
             key 91 = if \ Esc [ means CSI Sequence
                        key case
                              50 of key 126 = if togglemode then endof
                              51 of key 126 = if delete redraw-line then endof
                              65 of up endof
                              66 of down endof
                              67 of right-wrap endof
                              68 of left-wrap endof

                              70 of gotoeol endof \ End
                              72 of flushleft endof \ Pos 1
                            endcase
                        cursor
                      then
           endof
      endcase
    then
  again
;

( Testing )

columns rows * buffer: input

: sq ( -- )
  input columns rows * 32 fill \ Fill with Spaces
  input editor
;

\ Cornerstone for flash sectors with variable length

: sectorborder ( addr -- u )

  case
  
  \ --- 16 kb sectors ---
  
    $04000  of   1  endof
    $08000  of   2  endof
    $0C000  of   3  endof
  
  \ --- 64 kb sector  ---
  
    $10000  of   4  endof
  
  \ --- 128 kb sectors ---
  
    $20000  of   5  endof
    $40000  of   6  endof
    $60000  of   7  endof
    $80000  of   8  endof
    $A0000  of   9  endof
    $C0000  of  10  endof
    $E0000  of  11  endof
      
  \ Not on a sector border

  0 swap 
  endcase
;

: cornerstone ( Name ) ( -- )
  <builds begin here sectorborder 0= while 0 h, repeat
  does>   dint singletask
          begin dup  sectorborder 0= while 2+   repeat 
          sectorborder 12 swap ?do i eraseflashsector loop reset
;

cornerstone eraseflash
