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 print-arvelie #0a18 DEO
	#800f DEO

BRK

@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
	#010e DEO

BRK

@parse ( ztr -- )

	DUP zlen #05 EQU ?&on-arvgre
	DUP zlen #0a EQU ?&on-grearv
	#1234 phex #0a18 DEO
	( error )
	pztr #0a18 DEO
	#010f DEO

JMP2r

&on-arvgre ( ztr -- )

	( month ) INCk INC LDZk LIT "A SUB #00 SWP #000e MUL2 STH2
	( date ) INC LDZ2 bytedec STH2r ADD2 INC2
	( year ) ROT LDZ2 bytedec #07d6 ADD2
	print-greg
	#010f DEO

JMP2r

&on-grearv ( ztr -- )

	( year )
	STHk LDZ2 bytedec #0064 MUL2 INCr INCr
	STHkr LDZ2 bytedec ADD2 INCr INCr INCr
	DUP2
	( month )
	STHkr LDZ2 bytedec INCr INCr INCr
	( day )
	STHr LDZ2 bytedec #0001 SUB2
	doty SWP2 print-arvelie #0a18 DEO
	#010f DEO

JMP2r

@doty ( year* month* day* -- doty* )

	ROT2 ,&y STR2
	LIT2r 0000
	SWP2 NIP #01 SUB #00
	&l
		#00 OVR [ LIT2 &y $2 ] ROT diam STH2 ADD2r
		INC GTHk ?&l
	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 )
	DUP2 #0003 AND2 #0000 EQU2 ?&leap
	( all other years are not leap years )
	&not-leap
	POP2 #00

JMP2r
&leap POP2 #01 JMP2r

@print-greg ( doty* year* -- )

	pdec #2018 DEO
	pdec #0a18 DEO

JMP2r

@print-arvelie ( doty* year* -- )

	#07d6 SUB2 NIP
	( digit1 ) DUP #0a DIV emit-num
	( digit2 ) #0a [ DIVk MUL SUB ] emit-num
	( month ) DUP2 #000e DIV2 NIP #11 ADD emit-num
	( digit3 ) #000e [ DIV2k MUL2 SUB2 ] DUP2 #000a DIV2 NIP emit-num
	( digit4 ) #000a [ DIV2k MUL2 SUB2 ] NIP

( >> )

@emit-num ( num -- )

	#30 ADD #18 DEO

JMP2r

@bytedec ( byte -- dec* )

	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
@pztr ( ztr -- ) LDZk ?&w JMP2r &w LDZk #18 DEO INC LDZk ?&w POP JMP2r

@phex ( short* -- ) SWP phex/b &b DUP #04 SFT phex/c &c #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r

@pdec ( v* -- )

#00 ,&z STR
#2710 ,&parse JSR
#03e8 ,&parse JSR
#0064 ,&parse JSR
#000a ,&parse JSR
NIP
&emit
DUP [ LIT &z $1 ] EQU ,&skip JCN
#ff ,&z STR DUP #30 ADD #18 DEO
&skip
POP

JMP2r
&parse
DIV2k DUP ,&emit JSR MUL2 SUB2
JMP2r