uxn-utils/cli/arvelie/arvelie.tal

|10 @Console &vector $2 &read $1 &pad $4 &type $1 &write $1 &error $1
|c0 @DateTime &year $2 &month $1 &day $1 &hour $1 &minute $1 &second $1 &dotw $1 &doty $2 &isdst $1

|0000 @buf

|0100 ( -> )
	.Console/type DEI ?on-params
	( today )
	.DateTime/doty DEI2 .DateTime/year DEI2 emit-arv #0a18 DEO
	#800f DEO
BRK

(
@|vectors )

@on-params ( -> )
	;on-console .Console/vector DEO2
BRK

@on-console ( -> )
	.Console/read DEI
	DUP #21 LTH ?&validate
	.buf zput
BRK

&validate ( c -> )
	POP
	.buf parse
BRK

(
@|core )

@parse ( ztr -- )
	DUP zlen #05 EQU ?&on-arvgre
	DUP zlen #0a EQU ?&on-grearv
	;&err &w LDAk #19 DEO INC2 LDAk ?&w POP2
	#010f DEO
JMP2r

&on-arvgre ( ztr -- )
	( m ) INCk INC LDZk LIT "A SUB #00 SWP #000e MUL2 STH2
	( d ) INC bytedec STH2r ADD2 INC2
	( y ) ROT bytedec #07d6 ADD2
	emit-gre
	#0a18 DEO
	#800f DEO
JMP2r

&on-grearv ( ztr -- )
	( y ) STHk shortdec LIT2r 0005 ADD2r
	DUP2
	( m ) STHkr bytedec INCr INCr INCr
	( d ) STHr bytedec #0001 SUB2 doty
	SWP2
	emit-arv
	#0a18 DEO
	#800f DEO
JMP2r
&err "usage: 20 "arvelie.rom 20 "YYYY-MM-DD 0a $1

@emit-gre ( doty* year* -- )
	DUP2 emit-dec2 [ LIT2 "- 18 ] DEO
	,&y STR2
	STH2
	#0c00
	&l
		DUP [ LIT2 &y $2 ] ROT diam #00 SWP
			DUP2 STH2kr GTH2 ?&skip
				STH2k SUB2r !&continue
				&skip
			POP2 !&end
		&continue
			POP2
		INC GTHk ?&l
	&end
	NIP INC emit-dec [ LIT2 "- 18 ] DEO
	STHr POPr
!emit-dec

@emit-arv ( doty* year* -- )
	#07e0 SUB2 NIP
	( year ) emit-dec
	( month ) DUP2 #000e DIV2 NIP #11 ADD emit-num
	( digit3 ) #000e [ DIV2k MUL2 SUB2 ] NIP
!emit-dec

@emit-dec2 ( short* -- )
	#0064 DIV2k DUP emit-dec
	MUL2 SUB2 NIP
@emit-dec ( byte -- )
	DUP #0a DIV emit-num
	#0a DIVk MUL SUB
@emit-num ( num -- )
	LIT "0 ADD #18 DEO
JMP2r

(
@|utils )

@doty ( year* month* day* -- doty* )
	ROT2 ,&y STR2
	LIT2r 0000
	SWP2 NIP #01 SUB #00 EQUk ?&skip
	&l
		#00 OVR [ LIT2 &y $2 ] ROT diam STH2 ADD2r
		INC GTHk ?&l
	&skip
	POP2
	STH2r ADD2
JMP2r

@diam ( year* month -- days )
	#00 OVR ;&m ADD2 LDA
	SWP #01 NEQ ?&no-feb
		STH DUP2 is-leap-year STHr ADD
		&no-feb
	NIP NIP
JMP2r
	&m [ 1f 1c 1f 1e 1f 1e 1f 1f 1e 1f 1e 1f ]

@is-leap-year ( year* -- bool )
	( leap year if perfectly divisible by 400 )
	DUP2 #0190 ( MOD2 ) DIV2k MUL2 SUB2 #0000 EQU2 ?&leap
	( not a leap year if divisible by 100, but not divisible by 400 )
	DUP2 #0064 ( MOD2 ) DIV2k MUL2 SUB2 #0000 EQU2 ?&not-leap
	( leap year if not divisible by 100, but divisible by 4 )
	#0003 AND2 #0000 EQU2
JMP2r
	&not-leap
		POP2 #00
JMP2r
	&leap
		POP2 #01
JMP2r

@shortdec ( zp -- dec* )
	DUP bytedec #0064 MUL2
	ROT INC INC bytedec ADD2
JMP2r

@bytedec ( zp -- dec* )
	LDZ2
	LIT "0 SUB
	SWP LIT "0 SUB #0a MUL ADD
	#00 SWP
JMP2r

(
@|stdlib )

@zlen ( ztr -- len ) DUP zcap SWP SUB JMP2r
@zcap ( ztr -- end ) LDZk ?&w JMP2r &w INC LDZk ?&w JMP2r
@zput ( c ztr -- ) zcap STZ JMP2r