( a simple calculator )

%+  { ADD } %-   { SUB }              %/   { DIV }
%<  { LTH } %>   { GTH }  %=  { EQU } %!   { NEQ }
%++ { ADD2 } %-- { SUB2 }              %// { DIV2 }
%<< { LTH2 } %>> { GTH2 } %== { EQU2 } %!! { NEQ2 }

%2*   { #10 SFT } 
%4*   { #20 SFT } %4/ { #02 SFT }
%2**  { #10 SFT2 } %2// { #01 SFT2 }
%4**  { #20 SFT2 }
%8**  { #30 SFT2 } %8// { #03 SFT2 }
%10** { #40 SFT2 } %10// { #04 SFT2 }
%20** { #50 SFT2 }

%4MOD { #03 AND }

%DEBUG  { ;print-hex/byte JSR2 #0a .Console/write DEO }
%DEBUG2 { ;print-hex/short JSR2 #0a .Console/write DEO }

%RTN { JMP2r }
%SWP2? { #01 JCN SWP2 }
%BRK? { #01 JCN BRK }
%RTN? { #01 JCN RTN }
%TOS { #00 SWP }

( devices )

|00 @System     [ &vector $2 &wst      $1 &rst    $1 &pad   $4 &r      $2 &g      $2 &b    $2 &debug  $1 &halt $1 ]
|10 @Console    [ &vector $2 &read     $1 &pad    $5 &write $1 &error  $1 ]
|20 @Screen     [ &vector $2 &width    $2 &height $2 &auto  $1 &pad    $1 &x      $2 &y      $2 &addr $2 &pixel  $1 &sprite $1 ]
|30 @Audio0     [ &vector $2 &position $2 &output $1 &pad   $3 &adsr   $2 &length $2 &addr $2 &volume $1 &pitch $1 ]
|40 @Audio1     [ &vector $2 &position $2 &output $1 &pad   $3 &adsr   $2 &length $2 &addr $2 &volume $1 &pitch $1 ]
|50 @Audio2     [ &vector $2 &position $2 &output $1 &pad   $3 &adsr   $2 &length $2 &addr $2 &volume $1 &pitch $1 ]
|60 @Audio3     [ &vector $2 &position $2 &output $1 &pad   $3 &adsr   $2 &length $2 &addr $2 &volume $1 &pitch $1 ]
|80 @Controller [ &vector $2 &button   $1 &key    $1 ]
|90 @Mouse      [ &vector $2 &x        $2 &y      $2 &state $1 &wheel  $1 ]
|a0 @File       [ &vector $2 &success  $2 &offset-hs $2 &offset-ls $2 &name   $2 &length $2 &load $2 &save   $2 ]
|b0 @DateTime   [ &year   $2 &month    $1 &day    $1 &hour  $1 &minute $1 &second $1 &dotw $1 &doty   $2 &isdst $1 ]

( variables )

|0000

@input
	&length $1 &value $2
@stack
	&length $1
	&items $10
@center
	&x $2 &y $2
@pointer
	&x  $2 &y  $2
@keypad-frame
	&x $2 &y $2 &x2 $2 &y2 $2
@modpad-frame
	&x $2 &y $2 &x2 $2 &y2 $2
@input-frame
	&x $2 &y $2 &x2 $2 &y2 $2

( program )

|0100 ( -> )

	( theme ) 
	#0fef .System/r DEO2 
	#0fc5 .System/g DEO2 
	#0f25 .System/b DEO2

	( size )
	#0120 .Screen/width DEO2
	#0160 .Screen/height DEO2

	( vectors )
	;on-mouse .Mouse/vector DEO2
	;on-button .Controller/vector DEO2

	( center )
	.Screen/width DEI2 2// .center/x STZ2
	.Screen/height DEI2 2// .center/y STZ2

	.center/x LDZ2 #0028 -- 
	DUP2 .keypad-frame/x STZ2
		#0040 ++ .keypad-frame/x2 STZ2
	.center/y LDZ2 #0020 -- 
	DUP2 .keypad-frame/y STZ2
		#0040 ++ .keypad-frame/y2 STZ2

	.keypad-frame/x LDZ2 #0040 ++ 
	DUP2 .modpad-frame/x STZ2
		#0010 ++ .modpad-frame/x2 STZ2
	.keypad-frame/y LDZ2 
	DUP2 .modpad-frame/y STZ2
		#0040 ++ .modpad-frame/y2 STZ2

	.center/x LDZ2 #0028 -- 
	DUP2 .input-frame/x STZ2
		#0050 ++ .input-frame/x2 STZ2
	.center/y LDZ2 #0030 -- 
	DUP2 .input-frame/y STZ2
		#0010 ++ .input-frame/y2 STZ2

	;redraw JSR2

BRK

@on-button ( -> )

	.Controller/key DEI #00 ! ,&continue JCN
		;redraw JSR2 BRK
		&continue

	.Controller/key DEI 
	DUP #0d ! ,&no-enter JCN
		;do-push JSR2 POP BRK
		&no-enter
	DUP LIT '+ ! ,&no-add JCN 
		;do-add JSR2 POP BRK &no-add
	DUP LIT '- ! ,&no-sub JCN 
		;do-sub JSR2 POP BRK &no-sub
	DUP LIT '* ! ,&no-mul JCN 
		;do-mul JSR2 POP BRK &no-mul
	DUP LIT '/ ! ,&no-div JCN 
		;do-div JSR2 POP BRK &no-div
	DUP #1b ! ,&no-esc JCN
		;do-pop JSR2 POP BRK &no-esc
	DUP #08 ! ,&no-backspace JCN
		.input/value LDZ2 #04 SFT2 .input/value STZ2
		#ff ;draw-input JSR2
		POP BRK
		&no-backspace
	;key-value JSR2 ;push-input JSR2

BRK

@on-mouse ( -> )

	;pointer-icn .Screen/addr DEO2
	( clear last cursor )
	.pointer/x LDZ2 .Screen/x DEO2
	.pointer/y LDZ2 .Screen/y DEO2
	#40 .Screen/sprite DEO

	( record pointer positions )
	.Mouse/x DEI2 .pointer/x STZ2 
	.Mouse/y DEI2 .pointer/y STZ2

	( draw new cursor )
	.pointer/x LDZ2 .Screen/x DEO2
	.pointer/y LDZ2 .Screen/y DEO2
	#41 .Mouse/state DEI #01 = + .Screen/sprite DEO

	.Mouse/state DEI #00 ! ,&continue JCN
		;redraw JSR2 BRK
		&continue

	.Mouse/x DEI2 .Mouse/y DEI2 
	OVR2 OVR2 .keypad-frame 
		;within-rect JSR2 ;click-keypad JCN2
	OVR2 OVR2 .input-frame 
		;within-rect JSR2 ;click-input JCN2
	OVR2 OVR2 .modpad-frame 
		;within-rect JSR2 ;click-modpad JCN2
	POP2 POP2

BRK

@click-keypad ( x* y* -> )

	( get key )
	.keypad-frame/y LDZ2 -- 10// 4**
	SWP2 .keypad-frame/x LDZ2 -- 10// #0003 AND2
	++ ;keypad/layout ++ LDA ;push-input JSR2

	( release mouse ) #00 .Mouse/state DEO

BRK

@click-modpad ( x* y* -> )

	NIP2
	( get key )
	.modpad-frame/y LDZ2 -- 10// NIP
	DUP #00 ! ,&no-add JCN ;do-add JSR2 &no-add
	DUP #01 ! ,&no-sub JCN ;do-sub JSR2 &no-sub
	DUP #02 ! ,&no-mul JCN ;do-mul JSR2 &no-mul
	DUP #03 ! ,&no-div JCN ;do-div JSR2 &no-div
	POP

	( release mouse ) #00 .Mouse/state DEO

BRK

@click-input ( x* y* -> )

	POP2
	.input-frame/x LDZ2 #0008 ++ -- 10// NIP
	DUP #03 ! ,&no-push JCN
		.input/value LDZ2 #0001 << ,&no-push-empty JCN
			;do-push JSR2
			&no-push-empty
		&no-push
	DUP #04 ! ,&no-pop JCN
		;do-pop JSR2
		&no-pop
	POP

	( release mouse ) #00 .Mouse/state DEO

BRK

@push-input ( key -- )

	DUP TOS ;keypad/series ++ LDA ;draw-keypad JSR2
	TOS .input/value LDZ2 #40 SFT2 ++ .input/value STZ2
	.input/length LDZ INC .input/length STZ
	#ff ;draw-input JSR2

RTN

@push ( value* -- )

	( store ) .stack/length LDZ 2* .stack/items + STZ2
	( incr ) .stack/length LDZ INC .stack/length STZ
	( reset ) #0000 .input/value STZ2
	#00 ;draw-input JSR2
	;draw-stack JSR2

RTN

@pop ( -- value* )

	.stack/length LDZ #01 - 2* .stack/items + LDZ2
	( clear ) #0000 .stack/length LDZ #01 - 2* .stack/items + STZ2
	( incr ) .stack/length LDZ #01 - .stack/length STZ
	#01 ;draw-input JSR2
	;draw-stack JSR2

RTN

@do-push ( -- )

	.stack/length LDZ #07 < ,&continue JCN
		RTN
		&continue
	.input/value LDZ2 ;push JSR2

RTN

@do-pop ( -- )

	#0000 .input/value STZ2
	.stack/length LDZ #00 = ,&continue JCN
		;pop JSR2 POP2
		;draw-stack JSR2
		&continue
	#01 ;draw-input JSR2

RTN

@do-add ( -- )

	.input/value LDZ2 #0000 == ,&no-push JCN
		;do-push JSR2
		&no-push

	( stack empty ) .stack/length LDZ #01 > RTN?

	#00 ;draw-modpad JSR2
	;pop JSR2 ;pop JSR2 SWP2 ADD2 ;push JSR2

RTN

@do-sub ( -- )

	.input/value LDZ2 #0000 == ,&no-push JCN
		;do-push JSR2
		&no-push

	( stack empty ) .stack/length LDZ #01 > RTN?
	#01 ;draw-modpad JSR2
	;pop JSR2 ;pop JSR2 SWP2 SUB2 ;push JSR2

RTN

@do-mul ( -- )

	.input/value LDZ2 #0000 == ,&no-push JCN
		;do-push JSR2
		&no-push

	( stack empty ) .stack/length LDZ #01 > RTN?
	#02 ;draw-modpad JSR2
	;pop JSR2 ;pop JSR2 SWP2 MUL2 ;push JSR2

RTN

@do-div ( -- )

	.input/value LDZ2 #0000 == ,&no-push JCN
		;do-push JSR2
		&no-push

	( stack empty ) .stack/length LDZ #01 > RTN?
	#03 ;draw-modpad JSR2
	;pop JSR2 ;pop JSR2 SWP2 DIV2 ;push JSR2

RTN

@key-value ( key -- value )

	DUP #2f > OVR #3a < #0101 !! ,&no-num JCN
		#30 - RTN
		&no-num
	DUP #60 > OVR #67 < #0101 !! ,&no-lc JCN
		#57 - RTN ( #61 - #0a + )
		&no-lc
	DUP #40 > OVR #47 < #0101 !! ,&no-uc JCN
		#37 - RTN ( #41 - #0a + )
		&no-uc
	POP #00

RTN

@redraw ( -- )

	#ff ;draw-keypad JSR2
	#ff ;draw-modpad JSR2
	#ff ;draw-input JSR2
	;draw-stack JSR2

RTN

@draw-stack ( -- )

	#08 #00
	&loop
		( color ) DUP #08 .stack/length LDZ - #01 - > STH
		( value ) DUP 2* .stack/items + [ #10 .stack/length LDZ 2* - - ] LDZ2 STH2
		( y ) DUP TOS 8** .input-frame/y LDZ2 ++ #0048 -- STH2
		( x ) #0088 STH2r STH2r STHr ;draw-short JSR2
		INC GTHk ,&loop JCN
	POP2

RTN

@draw-short ( x* y* value* color -- )

	STH STH2
	.Screen/y DEO2
	.Screen/x DEO2
	#04 #00
	&loop
		.Screen/x DEI2 #0008 -- .Screen/x DEO2
		( value ) DUP STH2kr ROT 4* SFT2 #000f AND2
		( value glyph ) 8** ;font-hex ++ .Screen/addr DEO2
		ROTr STHkr ROTr ROTr .Screen/sprite DEO
		INC GTHk ,&loop JCN
	POP2
	POP2r POPr

RTN

@get-length ( short* -- length )

	DUP2 #0fff << ,&no4 JCN POP2 #04 RTN &no4
	DUP2 #00ff << ,&no3 JCN POP2 #03 RTN &no3
	DUP2 #000f << ,&no2 JCN POP2 #02 RTN &no2
	#0000 !!

RTN

@draw-input ( key -- )

	STH

	.input-frame/y LDZ2 #0002 ++ .Screen/y DEO2
	#04 #00
	&loop
		( x ) DUP TOS 8** .input-frame/x LDZ2 #0018 ++ SWP2 -- .Screen/x DEO2
		( value ) STHk .input/value LDZ2 STHr 4* SFT2 #000f AND2
		( value glyph ) 8** ;font-hex ++ .Screen/addr DEO2
		( color ) DUP INC .input/value LDZ2 ;get-length JSR2 >
		#01 + .Screen/sprite DEO
		INC GTHk ,&loop JCN
	POP2

	( controls )
	.input-frame/x LDZ2 #0030 ++
	.input-frame/y LDZ2
	;stack-icns/push [ STHkr #00 = ] #01
		;draw-key JSR2

	.input-frame/x LDZ2 #0040 ++
	.input-frame/y LDZ2
	;stack-icns/pop [ STHkr #01 = ] #02
		;draw-key JSR2

	( line )
	.input-frame/x LDZ2 
	.input-frame/x2 LDZ2 
	.input-frame/y LDZ2 #0004 -- #02 
		;line-hor-dotted JSR2

	POPr

RTN

@draw-keypad ( key -- )

	STH
	#10 #00
	&loop
		( color ) DUP TOS ;keypad/color ++ LDA STH
		( state ) DUP OVRr STHr = STH
		( layout ) DUP TOS ;keypad/layout ++ LDA 
			( layout addr ) TOS 8** ;font-hex ++ STH2
		( x ) DUP 4MOD TOS 10** STH2
		( y ) DUP 4/ TOS 10**
		( origin-x ) STH2r .keypad-frame/x LDZ2 ++ SWP2 
		( origin-y ) .keypad-frame/y LDZ2 ++
			STH2r STHr STHr ;draw-key JSR2
		INC GTHk ,&loop JCN
	POP2
	POPr

RTN

@draw-modpad ( key -- )

	STH
	#04 #00
	&loop
		( color ) #03 STH
		( state ) DUP OVRr STHr = STH
		( layout ) DUP TOS 8** ;mod-icns ++ STH2
		( x ) #0000 STH2
		( y ) DUP TOS 10**
		( origin-x ) STH2r .modpad-frame/x LDZ2 ++ SWP2 
		( origin-y ) .modpad-frame/y LDZ2 ++
			STH2r STHr STHr ;draw-key JSR2
		INC GTHk ,&loop JCN
	POP2
	POPr

RTN

@draw-key ( x* y* glyph* state color -- )

	( auto x addr ) #05 .Screen/auto DEO
	( color ) ,&color STR
	( state ) ,&state STR
	( glyph ) ,&glyph STR2
	( state ) ;button-icns [ #00 ,&state LDR 20** ++ ] .Screen/addr DEO2 
	( y* ) .Screen/y DEO2
	( x* ) .Screen/x DEO2
	( draw background )
	,&color LDR .Screen/sprite DEO
	,&color LDR .Screen/sprite DEO
	.Screen/x DEI2 #0010 -- .Screen/x DEO2
	.Screen/y DEI2 #0008 ++ .Screen/y DEO2
	,&color LDR .Screen/sprite DEO
	,&color LDR .Screen/sprite DEO
	( glyph )
	,&glyph LDR2 .Screen/addr DEO2
	.Screen/x DEI2 #000c -- .Screen/x DEO2
	.Screen/y DEI2 #0005 -- .Screen/y DEO2
	,&color LDR [ ,&state LDR #09 MUL + ] .Screen/sprite DEO
	( auto none ) #00 .Screen/auto DEO

RTN
	&color $1 &state $1 &glyph $2

@within-rect ( x* y* rect -- flag )
	
	STH
	( y < rect.y1 ) DUP2 STHkr #02 ADD LDZ2 LTH2 ,&skip JCN
	( y > rect.y2 ) DUP2 STHkr #06 ADD LDZ2 GTH2 ,&skip JCN
	SWP2
	( x < rect.x1 ) DUP2 STHkr LDZ2 LTH2 ,&skip JCN
	( x > rect.x2 ) DUP2 STHkr #04 ADD LDZ2 GTH2 ,&skip JCN
	POP2 POP2 POPr
	#01 
RTN
	&skip
	POP2 POP2 POPr
	#00

RTN

@line-hor-dotted ( x0* x1* y* color -- )
	
	STH .Screen/y DEO2
	SWP2
	&loop
		( save ) DUP2 .Screen/x DEO2
		( draw ) STHkr .Screen/pixel DEO
		INC2 INC2 GTH2k ,&loop JCN
	POP2 POP2 POPr

RTN

@print-hex ( value* -- )
	
	&short ( value* -- )
		SWP ,&echo JSR 
	&byte ( value -- )
		,&echo JSR
	RTN

	&echo ( value -- )
	STHk #04 SFT ,&parse JSR .Console/write DEO
	STHr #0f AND ,&parse JSR .Console/write DEO
	RTN
	&parse ( value -- char )
		DUP #09 GTH ,&above JCN #30 + RTN &above #09 - #60 + RTN

RTN

@keypad
	&layout
		0708 090f
		0405 060e
		0102 030d
		000a 0b0c
	&series
		0c08 090a
		0405 0600
		0102 0d0e
		0f0b 0703
	&color
		0101 0102
		0101 0102
		0101 0102
		0102 0202

@font-hex
	007c 8282 8282 827c 0030 1010 1010 1010
	007c 8202 7c80 80fe 007c 8202 1c02 827c
	000c 1424 4484 fe04 00fe 8080 7c02 827c
	007c 8280 fc82 827c 007c 8202 1e02 0202
	007c 8282 7c82 827c 007c 8282 7e02 827c
	007c 8202 7e82 827e 00fc 8282 fc82 82fc
	007c 8280 8080 827c 00fc 8282 8282 82fc
	007c 8280 f080 827c 007c 8280 f080 8080

@mod-icns
	0010 1010 fe10 1010
	0000 0000 fe00 0000
	0010 5428 c628 5410
	0010 0000 fe00 0010

@button-icns
	&outline
		3f40 8080 8080 8080
		f804 0202 0202 0202
		8080 8080 8040 3f00
		0202 0202 0204 f800
	&full
		3f7f ffff ffff ffff
		f8fc fefe fefe fefe
		ffff ffff ff7f 3f00
		fefe fefe fefc f800

@stack-icns
	&push
		0000 0010 2844 0000
	&pop
		0000 1038 7c38 1000

@pointer-icn
	80c0 e0f0 f8e0 1000