From a516173dcafbce5da0fcb1615acbc390652e4aaa Mon Sep 17 00:00:00 2001
From: Devine Lu Linvega <aliceffekt@gmail.com>
Date: Thu, 25 May 2023 11:51:02 -0700
Subject: [PATCH] Added doty routine

---
 cli/arvelie/arvelie.tal | 55 ++++++++++++++++++++++++++++++++++++-----
 1 file changed, 49 insertions(+), 6 deletions(-)

diff --git a/cli/arvelie/arvelie.tal b/cli/arvelie/arvelie.tal
index 5a4f242..9127bff 100644
--- a/cli/arvelie/arvelie.tal
+++ b/cli/arvelie/arvelie.tal
@@ -38,7 +38,6 @@ BRK
 
 @parse ( ztr -- )
 
-	DUP zlen phex/b #0a18 DEO
 	DUP zlen #05 EQU ?&on-arvgre
 	DUP zlen #0a EQU ?&on-grearv
 	#1234 phex #0a18 DEO
@@ -62,21 +61,59 @@ JMP2r
 
 	( year )
 	STHk LDZ2 bytedec #0064 MUL2 INCr INCr
-	STHkr LDZ2 bytedec ADD2 pdec #0a18 DEO INCr INCr INCr
+	STHkr LDZ2 bytedec ADD2 INCr INCr INCr
 	( month )
-	STHkr LDZ2 bytedec pdec #0a18 DEO INCr INCr INCr
+	STHkr LDZ2 bytedec INCr INCr INCr
 	( day )
-	STHr LDZ2 bytedec pdec #0a18 DEO
+	STHr LDZ2 bytedec
+
+		doty pdec #0a18 DEO
 	#010f DEO
 
 JMP2r
 
-@bytedec ( byte -- dec* )
+@doty ( year* month* day* -- doty* )
 
-	LIT "0 SUB SWP LIT "0 SUB #0a MUL ADD #00 SWP
+	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
@@ -101,6 +138,12 @@ JMP2r
 
 JMP2r
 
+@bytedec ( byte -- dec* )
+
+	LIT "0 SUB SWP LIT "0 SUB #0a MUL ADD #00 SWP
+
+JMP2r
+
 (
 @|stdlib )