Commit the interim work.  Needs testing.

Commit the interim work.  Needs testing.

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if hms advancetime then
   	dup inter.rtcdsem @offex! ?dup if dhms advancetime then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

: LOAD-DEFAULTS ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
struct ODN
	2 field odn.s
	2 field odn.m
	2 field odn.h
end-struct

udata
create NEEDLEMAX 3 cells allot
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

: rangecheck ( max n -- n or zero ) dup >R <= if R> drop 0 else R> then ;

: ++NEEDLE_S \ Called every time.
    odn_hms    odn.s   \ Stash this address for the moment.
	interp_max odn.s @ \ Get the max
	over w@             \ Current value
	interp_hms interp.a interp-next + \ Returns a value.

	\ If we've wrapped to zero, reset the interpolator
	\ the zero resets on every needle sweep.
    rangecheck ?dup if  interp_hms interp.a  interp-reset  then
    swap w!
;

: ++NEEDLE_DS ; \ Called every time.

: ++NEEDLE_M ; \ Every time we roll the seconds.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup w@ pwm0!
  2 + w@ pwm1!
  4 + w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  dup hms.w_m @ execute
  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

\ Heres the default values.   These are universal.
idata
create interp_max #850 , #850 , #850 ,
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a interp_max     @ raw_sec call3--
  2dup interp.b interp_max 4 + @     #60 call3--
       interp.c interp_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a interp_max     @  raw_dsec call3--
  2dup interp.b interp_max 4 + @      #100 call3--
       interp.c interp_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 or ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec
3 4 * equ _s_seth
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin
6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ 16 > if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_seth uistate ! true exit then
  uicount @ 48 > if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_pendset_m uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,
' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( n -- )
  icroot inter.rtcsem 0 over ! \ Reset the free-running counter.
  swap \ addr n --
  0 do
   dup @resetex! ?dup if advance else [asm wfi asm] then
  loop
  drop
;

: CLOCKINIT ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
;

\ Heres where we advance any needles.
: ADVANCE ( n -- )
  pwm0@ + pwm0!
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
udata
create NEEDLEMAX 3 cells allot
cdata

: ++NEEDLE_S ; \ Called ever time.
: ++NEEDLE_M ; \ Every time we roll the seconds.

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_s , ' ++needle_m , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
\ UNTESTED
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  dup hms.w_m @ execute
  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------

udata
create interp_a 4 cells allot
create interp_b 4 cells allot
create interp_c 4 cells allot
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init)
  dup interp_a #850 raw_sec call3--
  dup interp_b #850     #60 call3--
      interp_c #850     #12 call3--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--1

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV


fix 0= (bug from introduced 2 changesets ago)

( vi:ft=forth

  Implementations of some builtins.

  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  Copyright [C] 2011 Chris Liechti <cliechti@gmx.net>
  All Rights Reserved.
  Simplified BSD License [see LICENSE.txt for full text]
)

( ----- low level supporting functions ----- )

( > Put a literal [next element within thread] on the stack. )
CODE LIT
    ." \t push @IP+   \t; copy value from thread to stack \n "
    ASM-NEXT
END-CODE

( > Relative jump within a thread. )
CODE BRANCH
    ." \t add @IP, IP \n "
    ASM-NEXT
END-CODE

( > Realtive jump within a thread. But only jump if value on stack is false. )
CODE BRANCH0
    ." \t mov @IP+, W \t; get offset \n "
    ." \t tst 0(SP)   \t; check TOS \n "
    ." \t jnz .Lnjmp  \t; do not adjust IP if non zero \n "
    ." \t decd IP     \t; offset is relative to position of offset, correct \n "
    ." \t add W, IP   \t; adjust IP \n "
." .Lnjmp: "
    ASM-DROP
    ASM-NEXT
END-CODE

( ----- Stack ops ----- )

( > Remove value from top of stack. )
CODE DROP ( x -- )
    ." \t incd SP\n "
    ASM-NEXT
END-CODE

( > Duplicate value on top of stack. )
CODE DUP ( x -- x x )
(    ." \t push @SP\n " )
    ." \t mov @SP, W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( > Push a copy of the second element on the stack. )
CODE OVER ( y x -- y x y )
(    ." \t push 2(TOS\n " )
    ." \t mov 2(SP), W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( > Push a copy of the N'th element. )
CODE PICK ( n -- n )
    TOS->W                    ( get element number from stack )
    ." \t rla W " LF          ( multiply by 2 -> 2 byte / cell )
    ." \t add SP, W " LF      ( calculate address on stack )
    ." \t push 0(W) " LF
    ASM-NEXT
END-CODE

( > Exchange the two topmost values on the stack. )
CODE SWAP ( y x -- x y )
    ." \t mov 2(SP), W " LF
    ." \t mov 0(SP), 2(SP) " LF
    ." \t mov W, 0(SP) " LF
    ASM-NEXT
END-CODE

( ----- Return Stack ops ----- )

( > Move x to the return stack. )
CODE >R ( x -- ) ( R: -- x )
    ." \t decd RTOS \t; make room on the return stack\n "
    ." \t pop 0(RTOS) \t; pop value and put it on return stack\n "
    ASM-NEXT
END-CODE

( > Move x from the return stack to the data stack. )
CODE R> ( -- x ) ( R: x -- )
    ." \t push @RTOS+ \t; pop from return stack, push to data stack\n "
    ASM-NEXT
END-CODE

( > Copy x from the return stack to the data stack. )
CODE R@ ( -- x ) ( R: x -- x )
    ." \t push @RTOS \t; push copy of RTOS to data stack\n "
    ASM-NEXT
END-CODE

( ----- MATH ----- )

( > Add two 16 bit values. )
CODE + ( n n -- n )
    ." \t add 0(SP), 2(SP) \t; y = x + y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Subtract two 16 bit values. )
CODE - ( n n -- n )
    ." \t sub 0(SP), 2(SP) \t; y = y - x " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( ----- bit - ops ----- )
( > Bitwise AND. )
CODE AND ( n n -- n )
    ." \t and 0(SP), 2(SP) \t; y = x & y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise OR. )
CODE OR ( n n -- n )
    ." \t bis 0(SP), 2(SP) \t; y = x | y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise XOR. )
CODE XOR ( n n -- n )
    ." \t xor 0(SP), 2(SP) \t; y = x ^ y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise invert. )
CODE INVERT ( n -- n )
    ." \t inv 0(SP) \t; x = ~x " LF
    ASM-NEXT
END-CODE

( > Multiply by two [arithmetic left shift]. )
CODE 2* ( n -- n*2 )
    ." \t rla 0(SP) \t; x <<= 1 " LF
    ASM-NEXT
END-CODE

( > Divide by two [arithmetic right shift]. )
CODE 2/ ( n -- n/2 )
    ." \t rra 0(SP) \t; x >>= 1 " LF
    ASM-NEXT
END-CODE

( > Logical left shift by u bits. )
CODE LSHIFT ( n u -- n*2^u )
    TOS->W
    ." .lsh:\t clrc\n"
    ." \t rlc 0(SP) \t; x <<= 1\n"
    ." \t dec W\n"
    ." \t jnz .lsh\n"
    ASM-NEXT
END-CODE

( > Logical right shift by u bits. )
CODE RSHIFT ( n u -- n/2^u )
    TOS->W
    ." .rsh:\t clrc\n"
    ." \t rrc 0(SP) \t; x >>= 1\n"
    ." \t dec W\n"
    ." \t jnz .rsh\n"
    ASM-NEXT
END-CODE

( ----- Logic ops ----- )
(  0 - false
  -1 - true
)
( > Boolean invert. )
CODE NOT ( b -- b )  ( XXX alias 0= )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jz  __set_true " LF
    ." \t jmp __set_false " LF
END-CODE

( ---------------------------------------------------
    "*"
    "/"
)
( ----- Compare ----- )
( > Internal helper. Providing several labels to be called from assembler:
( >
( > - ``__set_true``    stack: ``x -- true`` )
( > - ``__set_false``   stack: ``x -- false`` )
( > - ``__drop_and_set_true``  stack: ``x y -- true`` )
( > - ``__drop_and_set_false`` stack: ``x y -- false`` )
CODE __COMPARE_HELPER
    ." __drop_and_set_true:" LF
    ASM-DROP                        ( remove 1st argument )
    ." __set_true:" LF
    ." \t mov \x23 -1, 0(SP) " LF    ( replace 2nd argument w/ result )
    ASM-NEXT

    ." __drop_and_set_false:" LF
    ASM-DROP                        ( remove 1st argument )
    ." __set_false:" LF
    ." \t mov \x23 0, 0(SP) " LF    ( replace 2nd argument w/ result )
    ASM-NEXT
END-CODE

( > Compare two numbers. )
CODE < ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jl  __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Compare two numbers. )
CODE > ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 2(SP), 0(SP) " LF
    ." \t jl  __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Compare two numbers. )
CODE <= ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jge __drop_and_set_false " LF
    ." \t jmp __drop_and_set_true " LF
END-CODE

( > Compare two numbers. )
CODE >= ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jge __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Tests two numbers for equality. )
CODE == ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jeq __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( XXX alias for == )
( > Tests two numbers for equality. )
CODE = ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jeq __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Tests two numbers for unequality. )
CODE != ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jne __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Test if number equals zero. )
CODE 0= ( x -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jz  __set_true " LF
    ." \t jmp __set_false " LF
END-CODE

( > Test if number is positive. )
CODE 0> ( x -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jn  __set_false " LF
    ." \t jmp __set_true " LF
END-CODE

( --------------------------------------------------- )

( XXX Forth name ERASE conflicts with FCTL bit name in MSP430 )
( > Erase memory area. )
CODE ZERO ( adr u -- )
    TOS->W      ( count )
    TOS->R15    ( address )
    ." .erase_loop: clr.b 0(R15)\n"
    ." \t inc R15\n"
    ." \t dec W\n"
    ." \t jnz .erase_loop\n"
    ASM-NEXT
END-CODE

( --------------------------------------------------- )
( > internal helper for ``."`` )
CODE __write_text ( -- )
    ." \t mov @IP+, R15\n"
    ." \t call \x23 write\n"
    ASM-NEXT
END-CODE

( vi:ft=forth

  Implementations of some builtins.

  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  Copyright [C] 2011 Chris Liechti <cliechti@gmx.net>
  All Rights Reserved.
  Simplified BSD License [see LICENSE.txt for full text]
)

( ----- low level supporting functions ----- )

( > Put a literal [next element within thread] on the stack. )
CODE LIT
    ." \t push @IP+   \t; copy value from thread to stack \n "
    ASM-NEXT
END-CODE

( > Relative jump within a thread. )
CODE BRANCH
    ." \t add @IP, IP \n "
    ASM-NEXT
END-CODE

( > Realtive jump within a thread. But only jump if value on stack is false. )
CODE BRANCH0
    ." \t mov @IP+, W \t; get offset \n "
    ." \t tst 0(SP)   \t; check TOS \n "
    ." \t jnz .Lnjmp  \t; do not adjust IP if non zero \n "
    ." \t decd IP     \t; offset is relative to position of offset, correct \n "
    ." \t add W, IP   \t; adjust IP \n "
." .Lnjmp: "
    ASM-DROP
    ASM-NEXT
END-CODE

( ----- Stack ops ----- )

( > Remove value from top of stack. )
CODE DROP ( x -- )
    ." \t incd SP\n "
    ASM-NEXT
END-CODE

( > Duplicate value on top of stack. )
CODE DUP ( x -- x x )
(    ." \t push @SP\n " )
    ." \t mov @SP, W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( > Push a copy of the second element on the stack. )
CODE OVER ( y x -- y x y )
(    ." \t push 2(TOS\n " )
    ." \t mov 2(SP), W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( > Push a copy of the N'th element. )
CODE PICK ( n -- n )
    TOS->W                    ( get element number from stack )
    ." \t rla W " LF          ( multiply by 2 -> 2 byte / cell )
    ." \t add SP, W " LF      ( calculate address on stack )
    ." \t push 0(W) " LF
    ASM-NEXT
END-CODE

( > Exchange the two topmost values on the stack. )
CODE SWAP ( y x -- x y )
    ." \t mov 2(SP), W " LF
    ." \t mov 0(SP), 2(SP) " LF
    ." \t mov W, 0(SP) " LF
    ASM-NEXT
END-CODE

( ----- Return Stack ops ----- )

( > Move x to the return stack. )
CODE >R ( x -- ) ( R: -- x )
    ." \t decd RTOS \t; make room on the return stack\n "
    ." \t pop 0(RTOS) \t; pop value and put it on return stack\n "
    ASM-NEXT
END-CODE

( > Move x from the return stack to the data stack. )
CODE R> ( -- x ) ( R: x -- )
    ." \t push @RTOS+ \t; pop from return stack, push to data stack\n "
    ASM-NEXT
END-CODE

( > Copy x from the return stack to the data stack. )
CODE R@ ( -- x ) ( R: x -- x )
    ." \t push @RTOS \t; push copy of RTOS to data stack\n "
    ASM-NEXT
END-CODE

( ----- MATH ----- )

( > Add two 16 bit values. )
CODE + ( n n -- n )
    ." \t add 0(SP), 2(SP) \t; y = x + y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Subtract two 16 bit values. )
CODE - ( n n -- n )
    ." \t sub 0(SP), 2(SP) \t; y = y - x " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( ----- bit - ops ----- )
( > Bitwise AND. )
CODE AND ( n n -- n )
    ." \t and 0(SP), 2(SP) \t; y = x & y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise OR. )
CODE OR ( n n -- n )
    ." \t bis 0(SP), 2(SP) \t; y = x | y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise XOR. )
CODE XOR ( n n -- n )
    ." \t xor 0(SP), 2(SP) \t; y = x ^ y " LF
    ASM-DROP
    ASM-NEXT
END-CODE

( > Bitwise invert. )
CODE INVERT ( n -- n )
    ." \t inv 0(SP) \t; x = ~x " LF
    ASM-NEXT
END-CODE

( > Multiply by two [arithmetic left shift]. )
CODE 2* ( n -- n*2 )
    ." \t rla 0(SP) \t; x <<= 1 " LF
    ASM-NEXT
END-CODE

( > Divide by two [arithmetic right shift]. )
CODE 2/ ( n -- n/2 )
    ." \t rra 0(SP) \t; x >>= 1 " LF
    ASM-NEXT
END-CODE

( > Logical left shift by u bits. )
CODE LSHIFT ( n u -- n*2^u )
    TOS->W
    ." .lsh:\t clrc\n"
    ." \t rlc 0(SP) \t; x <<= 1\n"
    ." \t dec W\n"
    ." \t jnz .lsh\n"
    ASM-NEXT
END-CODE

( > Logical right shift by u bits. )
CODE RSHIFT ( n u -- n/2^u )
    TOS->W
    ." .rsh:\t clrc\n"
    ." \t rrc 0(SP) \t; x >>= 1\n"
    ." \t dec W\n"
    ." \t jnz .rsh\n"
    ASM-NEXT
END-CODE

( ----- Logic ops ----- )
(  0 - false
  -1 - true
)
( > Boolean invert. )
CODE NOT ( b -- b )  ( XXX alias 0= )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jz  __set_true " LF
    ." \t jmp __set_false " LF
END-CODE

( ---------------------------------------------------
    "*"
    "/"
)
( ----- Compare ----- )
( > Internal helper. Providing several labels to be called from assembler:
( >
( > - ``__set_true``    stack: ``x -- true`` )
( > - ``__set_false``   stack: ``x -- false`` )
( > - ``__drop_and_set_true``  stack: ``x y -- true`` )
( > - ``__drop_and_set_false`` stack: ``x y -- false`` )
CODE __COMPARE_HELPER
    ." __drop_and_set_true:" LF
    ASM-DROP                        ( remove 1st argument )
    ." __set_true:" LF
    ." \t mov \x23 -1, 0(SP) " LF    ( replace 2nd argument w/ result )
    ASM-NEXT

    ." __drop_and_set_false:" LF
    ASM-DROP                        ( remove 1st argument )
    ." __set_false:" LF
    ." \t mov \x23 0, 0(SP) " LF    ( replace 2nd argument w/ result )
    ASM-NEXT
END-CODE

( > Compare two numbers. )
CODE < ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jl  __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Compare two numbers. )
CODE > ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 2(SP), 0(SP) " LF
    ." \t jl  __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Compare two numbers. )
CODE <= ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jge __drop_and_set_false " LF
    ." \t jmp __drop_and_set_true " LF
END-CODE

( > Compare two numbers. )
CODE >= ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jge __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Tests two numbers for equality. )
CODE == ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jeq __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( XXX alias for == )
( > Tests two numbers for equality. )
CODE = ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jeq __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Tests two numbers for unequality. )
CODE != ( x y -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t cmp 0(SP), 2(SP) " LF
    ." \t jne __drop_and_set_true " LF
    ." \t jmp __drop_and_set_false " LF
END-CODE

( > Test if number equals zero. )
CODE 0= ( x -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jz  __set_false " LF
    ." \t jmp __set_true " LF
END-CODE

( > Test if number is positive. )
CODE 0> ( x -- b )
    DEPENDS-ON __COMPARE_HELPER
    ." \t tst 0(SP) " LF
    ." \t jn  __set_false " LF
    ." \t jmp __set_true " LF
END-CODE

( --------------------------------------------------- )

( XXX Forth name ERASE conflicts with FCTL bit name in MSP430 )
( > Erase memory area. )
CODE ZERO ( adr u -- )
    TOS->W      ( count )
    TOS->R15    ( address )
    ." .erase_loop: clr.b 0(R15)\n"
    ." \t inc R15\n"
    ." \t dec W\n"
    ." \t jnz .erase_loop\n"
    ASM-NEXT
END-CODE

( --------------------------------------------------- )
( > internal helper for ``."`` )
CODE __write_text ( -- )
    ." \t mov @IP+, R15\n"
    ." \t call \x23 write\n"
    ASM-NEXT
END-CODE


Add assigns for hp ht hsc (#156)

Add assigns for hp ht hsc (#156)

So you can:    include hp:xforms.fth

\ $Id$
\ LOAD HMSL
\
\ Author: Phil Burk
\ Copyright 1986 -  Phil Burk, Larry Polansky, David Rosenboom.
\
ANEW TASK-LOAD_HMSL

false constant HOST=AMIGA
true constant HOST=MAC

: '  ( <name> -- cfa , warn me if used the wrong way )
    state @
    IF
        ." ' used! ====================" cr
        source type cr
        ." ============================" cr
        postpone '
    ELSE
        '
    THEN
; immediate

include? task-stubs fth/stubs.fth

: [NEED] ( <name> -- start compiling if not found )
    postpone exists? not postpone [IF]
;

\ Decide whether to compile different parts of HMSL.
[need] IF-LOAD-MIDI
variable IF-LOAD-MIDI
variable IF-LOAD-ACTIONS
variable IF-LOAD-MORPHS
variable IF-LOAD-GRAPHICS
variable IF-LOAD-SHAPE-ED
variable IF-LOAD-DEMO
if-load-demo off
[THEN]

\ SET THESE VARIABLES TO CONTROL WHAT GETS LOADED!!!!
TRUE if-load-midi !
TRUE if-load-morphs !
TRUE if-load-actions !    ( perform screen )
TRUE if-load-graphics !
if-load-morphs @ if-load-shape-ed !

if-load-midi @ 0= [IF] ." Not loading MIDI support!" cr [THEN]
if-load-actions @ 0= [IF] ." Not loading Actions or Perform Screen!" cr [THEN]
if-load-graphics @ 0= [IF] ." Not loading Graphics Support" cr [THEN]
if-load-shape-ed @ 0= [IF] ." Not loading Shape Editor" cr [THEN]

\ Start of cascaded initialization and termination.
exists? SYS.INIT not [if]
    : SYS.INIT ;
    : SYS.TERM ;
    : SYS.RESET ;
[THEN]

exists?  SYS.CLEANUP not [if]
    : SYS.CLEANUP ; \ less severe then SYS.RESET
    : SYS.START ;
    : SYS.STOP ;
    : SYS.TASK ;
[THEN]

exists? SYS.STATUS not [if]
    : SYS.STATUS >newline ;
[THEN]

include? within?                fth/p4thbase.fth
include? toupper                fth/charmacr.fth

include? task-misc_tools        fth/misc_tools.fth
include? task-utils             fth/utils.fth
include? stack.header           fth/stacks.fth

include? task-errormsg          fth/errormsg.fth
include? task-memalloc          fth/memalloc.fth
include? task-cond_comp         fth/cond_comp.fth

include? task-global_data       fth/global_data.fth
include? task-service_tasks     fth/service_tasks.fth
include? task-float_port        fth/float_port.fth

\ MIDI and Time support-------------------------------
if-load-midi @ [IF]
  include? task-midi_globals fth/midi_globals.fth
  include? task-time fth/time.fth
  include? task-midi fth/midi.fth
  include? task-midi_parser fth/midi_parser.fth
  include? task-midi_text fth/midi_text.fth
[ELSE]
  include? task-midi_stubs fth/midi_stubs.fth
[THEN]

\
\ Object Oriented Code -------------------------
include? task-ob_stack fth/ob_stack.fth
include? task-ob_main fth/ob_main.fth
include? task-ob_bind fth/ob_bind.fth
include? task-obmethod fth/obmethod.fth
mreset-warn off
include? task-ob_ivars fth/ob_ivars.fth
include? task-dbl_list fth/dbl_list.fth
include? task-obobject fth/obobject.fth
include? task-ob_array fth/ob_array.fth
include? task-elmnts fth/elmnts.fth
include? task-ob_dlist fth/ob_dlist.fth

\ Support for interactive screens
if-load-graphics @ [IF]
  include? task-graphics fth/graphics.fth
  include? task-graph_util fth/graph_util.fth
  include? task-scg fth/scg.fth
  include? task-bevel fth/bevel.fth
  include? task-control fth/control.fth
  include? task-ctrl_count fth/ctrl_count.fth
  include? task-ctrl_numeric fth/ctrl_numeric.fth
  include? task-ctrl_fader fth/ctrl_fader.fth
  include? task-screen fth/screen.fth
  include? task-ctrl_text fth/ctrl_text.fth
  include? task-popup_text fth/popup_text.fth
[THEN]

\ HMSL Music Morphs
if-load-morphs @ [IF]
include? task-morph_lists fth/morph_lists.fth
include? task-morph fth/morph.fth
include? task-actobj fth/actobj.fth
include? task-collection fth/collection.fth
include? task-shape fth/shape.fth
include? task-structure fth/structure.fth
include? task-production fth/production.fth
include? task-event_list fth/event_list.fth
include? task-allocator fth/allocator.fth
include? task-translators fth/translators.fth
include? task-instrument fth/instrument.fth
if-load-midi @ [IF]
include? task-midi_instrument fth/midi_instrument.fth
[THEN]
include? task-job fth/job.fth
include? task-player fth/player.fth
include? task-interpreters fth/interpreters.fth
[THEN]

\ Some predefined morphs.
if-load-morphs @ [IF]
include? task-stock_morphs fth/stock_morphs.fth
[THEN]

if-load-graphics @ [IF]
include? task-build_menus fth/build_menus.fth
[THEN]

if-load-demo @ 0= if-load-morphs @ and [IF]
include? task-record fth/record.fth
include? task-packed_midi fth/packed_midi.fth
[THEN]

include? task-top fth/top.fth

\ include? task-set_vectors fth/set_vectors.fth
include? task-hmsl_version fth/hmsl_version.fth
include? task-hmsl_top fth/hmsl_top.fth
include? task-startup fth/startup.fth

\ Editors in screen are loaded on top of the regular HMSL
if-load-graphics @   if-load-shape-ed @ AND [IF]
    include? task-shape_editor fth/shape_editor.fth
[THEN]

\ Load actions by Larry Polansky ,  "PERFORM" module
if-load-graphics @ if-load-actions @ AND [IF]
    include? task-action_utils fth/action_utils.fth
    include? task-ob_actions fth/ob_actions.fth
    include? task-test_actions fth/test_actions.fth
    include? task-action_table fth/action_table.fth
    include? task-action_screen fth/action_screen.fth
    include? task-action_top fth/action_top.fth
[THEN]

\ load some tools
include? assign            tools/assigns.fth
include? file_port         tools/file_port.fth
include? task-midifile     tools/midifile.fth
include? task-markov_chain tools/markov_chain.fth
include? task-score_entry  tools/score_entry.fth
include? task-bend_tuning  tools/bend_tuning.fth
include? task-bend_score   tools/bend_score.fth

\ Set common HMSL named folder assignments.
assign hmsl .
assign hp   hmsl:pieces
assign ht   hmsl:tools
assign hsc  hmsl:screens

mreset-warn on
cr ." HMSL compilation finished." cr
map

ANEW SESSION

\ $Id$
\ LOAD HMSL
\
\ Author: Phil Burk
\ Copyright 1986 -  Phil Burk, Larry Polansky, David Rosenboom.
\
ANEW TASK-LOAD_HMSL

false constant HOST=AMIGA
true constant HOST=MAC

: '  ( <name> -- cfa , warn me if used the wrong way )
    state @
    IF
        ." ' used! ====================" cr
        source type cr
        ." ============================" cr
        postpone '
    ELSE
        '
    THEN
; immediate

include? task-stubs fth/stubs.fth

: [NEED] ( <name> -- start compiling if not found )
    postpone exists? not postpone [IF]
;

\ Decide whether to compile different parts of HMSL.
[need] IF-LOAD-MIDI
variable IF-LOAD-MIDI
variable IF-LOAD-ACTIONS
variable IF-LOAD-MORPHS
variable IF-LOAD-GRAPHICS
variable IF-LOAD-SHAPE-ED
variable IF-LOAD-DEMO
if-load-demo off
[THEN]

\ SET THESE VARIABLES TO CONTROL WHAT GETS LOADED!!!!
TRUE if-load-midi !
TRUE if-load-morphs !
TRUE if-load-actions !    ( perform screen )
TRUE if-load-graphics !
if-load-morphs @ if-load-shape-ed !

if-load-midi @ 0= [IF] ." Not loading MIDI support!" cr [THEN]
if-load-actions @ 0= [IF] ." Not loading Actions or Perform Screen!" cr [THEN]
if-load-graphics @ 0= [IF] ." Not loading Graphics Support" cr [THEN]
if-load-shape-ed @ 0= [IF] ." Not loading Shape Editor" cr [THEN]

\ Start of cascaded initialization and termination.
exists? SYS.INIT not [if]
    : SYS.INIT ;
    : SYS.TERM ;
    : SYS.RESET ;
[THEN]

exists?  SYS.CLEANUP not [if]
    : SYS.CLEANUP ; \ less severe then SYS.RESET
    : SYS.START ;
    : SYS.STOP ;
    : SYS.TASK ;
[THEN]

exists? SYS.STATUS not [if]
    : SYS.STATUS >newline ;
[THEN]

include? within?                fth/p4thbase.fth
include? toupper                fth/charmacr.fth

include? task-misc_tools        fth/misc_tools.fth
include? task-utils             fth/utils.fth
include? stack.header           fth/stacks.fth

include? task-errormsg          fth/errormsg.fth
include? task-memalloc          fth/memalloc.fth
include? task-cond_comp         fth/cond_comp.fth

include? task-global_data       fth/global_data.fth
include? task-service_tasks     fth/service_tasks.fth
include? task-float_port        fth/float_port.fth

\ MIDI and Time support-------------------------------
if-load-midi @ [IF]
  include? task-midi_globals fth/midi_globals.fth
  include? task-time fth/time.fth
  include? task-midi fth/midi.fth
  include? task-midi_parser fth/midi_parser.fth
  include? task-midi_text fth/midi_text.fth
[ELSE]
  include? task-midi_stubs fth/midi_stubs.fth
[THEN]

\
\ Object Oriented Code -------------------------
include? task-ob_stack fth/ob_stack.fth
include? task-ob_main fth/ob_main.fth
include? task-ob_bind fth/ob_bind.fth
include? task-obmethod fth/obmethod.fth
mreset-warn off
include? task-ob_ivars fth/ob_ivars.fth
include? task-dbl_list fth/dbl_list.fth
include? task-obobject fth/obobject.fth
include? task-ob_array fth/ob_array.fth
include? task-elmnts fth/elmnts.fth
include? task-ob_dlist fth/ob_dlist.fth

\ Support for interactive screens
if-load-graphics @ [IF]
  include? task-graphics fth/graphics.fth
  include? task-graph_util fth/graph_util.fth
  include? task-scg fth/scg.fth
  include? task-bevel fth/bevel.fth
  include? task-control fth/control.fth
  include? task-ctrl_count fth/ctrl_count.fth
  include? task-ctrl_numeric fth/ctrl_numeric.fth
  include? task-ctrl_fader fth/ctrl_fader.fth
  include? task-screen fth/screen.fth
  include? task-ctrl_text fth/ctrl_text.fth
  include? task-popup_text fth/popup_text.fth
[THEN]

\ HMSL Music Morphs
if-load-morphs @ [IF]
include? task-morph_lists fth/morph_lists.fth
include? task-morph fth/morph.fth
include? task-actobj fth/actobj.fth
include? task-collection fth/collection.fth
include? task-shape fth/shape.fth
include? task-structure fth/structure.fth
include? task-production fth/production.fth
include? task-event_list fth/event_list.fth
include? task-allocator fth/allocator.fth
include? task-translators fth/translators.fth
include? task-instrument fth/instrument.fth
if-load-midi @ [IF]
include? task-midi_instrument fth/midi_instrument.fth
[THEN]
include? task-job fth/job.fth
include? task-player fth/player.fth
include? task-interpreters fth/interpreters.fth
[THEN]

\ Some predefined morphs.
if-load-morphs @ [IF]
include? task-stock_morphs fth/stock_morphs.fth
[THEN]

if-load-graphics @ [IF]
include? task-build_menus fth/build_menus.fth
[THEN]

if-load-demo @ 0= if-load-morphs @ and [IF]
include? task-record fth/record.fth
include? task-packed_midi fth/packed_midi.fth
[THEN]

include? task-top fth/top.fth

\ include? task-set_vectors fth/set_vectors.fth
include? task-hmsl_version fth/hmsl_version.fth
include? task-hmsl_top fth/hmsl_top.fth
include? task-startup fth/startup.fth

\ Editors in screen are loaded on top of the regular HMSL
if-load-graphics @   if-load-shape-ed @ AND [IF]
    include? task-shape_editor fth/shape_editor.fth
[THEN]

\ Load actions by Larry Polansky ,  "PERFORM" module
if-load-graphics @ if-load-actions @ AND [IF]
    include? task-action_utils fth/action_utils.fth
    include? task-ob_actions fth/ob_actions.fth
    include? task-test_actions fth/test_actions.fth
    include? task-action_table fth/action_table.fth
    include? task-action_screen fth/action_screen.fth
    include? task-action_top fth/action_top.fth
[THEN]

\ load some tools
include? assign    tools/assigns.fth
include? file_port tools/file_port.fth
include? task-midifile tools/midifile.fth
include? task-markov_chain tools/markov_chain.fth
include? task-score_entry tools/score_entry.fth
include? task-bend_tuning  tools/bend_tuning.fth
include? task-bend_score  tools/bend_score.fth

mreset-warn on
cr ." HMSL compilation finished." cr
map

ANEW SESSION


Directly call the 'boot' word instead of indirectly evaluating it.

Submitted by: dcs

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /       " 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
at-xy ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	2dup at-xy ."              ,        ," 1+
	2dup at-xy ."             /(        )`" 1+
	2dup at-xy ."             \ \___   / |" 1+
	2dup at-xy ."             /- _  `-/  '" 1+
	2dup at-xy ."            (/\/ \ \   /\" 1+
	2dup at-xy ."            / /   | `    \" 1+
	2dup at-xy ."            O O   ) /    |" 1+
	2dup at-xy ."            `-^--'`<     '" 1+
	2dup at-xy ."           (_.)  _  )   /" 1+
	2dup at-xy ."            `.___/`    /" 1+
	2dup at-xy ."              `-----' /" 1+
	2dup at-xy ." <----.     __ / __   \" 1+
	2dup at-xy ." <----|====O)))==) \) /====" 1+
	2dup at-xy ." <----'    `--' `.__,' \" 1+
	2dup at-xy ."              |        |" 1+
	2dup at-xy ."               \       /       /\" 1+
	2dup at-xy ."          ______( (_  / \______/" 1+
	2dup at-xy ."        ,'  ,-----'   |" 1+
	     at-xy ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if 0 boot then
		dup 13 = if 0 boot then
		dup bootkey @ = if 0 boot then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			0 boot
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			0 boot
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			0 boot
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			0 boot
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if s" reboot" evaluate then
	repeat
;

previous

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /       " 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
at-xy ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	2dup at-xy ."              ,        ," 1+
	2dup at-xy ."             /(        )`" 1+
	2dup at-xy ."             \ \___   / |" 1+
	2dup at-xy ."             /- _  `-/  '" 1+
	2dup at-xy ."            (/\/ \ \   /\" 1+
	2dup at-xy ."            / /   | `    \" 1+
	2dup at-xy ."            O O   ) /    |" 1+
	2dup at-xy ."            `-^--'`<     '" 1+
	2dup at-xy ."           (_.)  _  )   /" 1+
	2dup at-xy ."            `.___/`    /" 1+
	2dup at-xy ."              `-----' /" 1+
	2dup at-xy ." <----.     __ / __   \" 1+
	2dup at-xy ." <----|====O)))==) \) /====" 1+
	2dup at-xy ." <----'    `--' `.__,' \" 1+
	2dup at-xy ."              |        |" 1+
	2dup at-xy ."               \       /       /\" 1+
	2dup at-xy ."          ______( (_  / \______/" 1+
	2dup at-xy ."        ,'  ,-----'   |" 1+
	     at-xy ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if s" boot" evaluate then
		dup 13 = if s" boot" evaluate then
		dup bootkey @ = if s" boot" evaluate then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			s" boot" evaluate
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			s" boot" evaluate
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			s" boot" evaluate
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			s" boot" evaluate
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if s" reboot" evaluate then
	repeat
;

previous


Adjust the quadrature encoder for detent accuracy.

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	int odn.s
	int odn.m
	int odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------
: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  _USERDATA
  dup      @ -1 <>
  over 4 + @ -1 <> and
  swap 8 + @ -1 <> and
;

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

_timer1 $24 + equ QUAD-IN

\ The Quadrature encoder produces two per detent.
: QUAD@ ( -- n ) \ Fetch and zero
  quad-in @off
  [asm sxth tos, tos asm]
  [asm asr .s tos, tos, # 1 asm] \ Divide by two,
  ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  dup hms.w_m @ execute
  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a needle_max     @ raw_sec call3--
  2dup interp.b needle_max 4 + @     #60 call3--
       interp.c needle_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a needle_max     @  raw_dsec call3--
  2dup interp.b needle_max 4 + @      #100 call3--
       interp.c needle_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 xor ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec

3 4 * equ _s_set_h
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin

6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

4 equ downcount_1s
16 equ downcount_3s

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ downcount_1s >= if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_set_h uistate ! exit then
  uicount @ downcount_3s >= if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_init uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	int odn.s
	int odn.m
	int odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------
: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  _USERDATA
  dup      @ -1 <>
  over 4 + @ -1 <> and
  swap 8 + @ -1 <> and
;

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  dup hms.w_m @ execute
  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a needle_max     @ raw_sec call3--
  2dup interp.b needle_max 4 + @     #60 call3--
       interp.c needle_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a needle_max     @  raw_dsec call3--
  2dup interp.b needle_max 4 + @      #100 call3--
       interp.c needle_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 xor ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec

3 4 * equ _s_set_h
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin

6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

4 equ downcount_1s
16 equ downcount_3s

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ downcount_1s >= if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_set_h uistate ! exit then
  uicount @ downcount_3s >= if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_init uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,