; CALENDAR Parx module
; Guillaume Tello
; guillaume.tello@orange.fr
; july 2024

GEMDOS MACRO    ; fn,pile
   move #\1,-(sp)
   trap #1
   if \2<=8
      addq.l #\2,sp
   else
      add.w #\2,sp
   endif
   ENDM

		section	text

debut:	
	dc.b "READ_FOM"	; identifiant module g‚n‚ral FORTH
	dc.b "DATE"			; objets support‚s
	dc.w $0000			; type 0 pour "chargement total"
	dc.b "CALENDAR"	; nom court
	dc.w 100				; version 1.00
	dc.b "Calendar FORTH module ½GT 2024",0 ; long name (30 octets + 1 z‚ro)
	dc.b 2+1				; marqueur mots red‚finis (2) + marqueur do_param (1)
	bra modinfo
	bra modpal
	bra modexe
	bra do_param

	dc.b "set_calendar",0	; red‚finit modinfo
	dc.b 0						; modpal ignor‚
	dc.b "calendar",0			; red‚finit modexe
	even							; assure la parit‚
		
	; langue ordre p modinfo
modinfo:
	lea ordre(pc),a0
	move.l (a6)+,d0	; ordre MJA si 0, JMA autre
	move d0,(a0)
	move.l (a6)+,d0	; code langue
	bmi.s .defaut
	cmp #9,d0
	bpl.s .defaut		; au dela, rien de pr‚vu
	move.b .index_langue(pc,d0),d0	; de 0 … 8, prendre la langue correspondante
	bra.s .ok
.defaut:
	moveq #0,d0			; anglais
.ok:
	move d0,-(a0)
	bsr set_langue	
	moveq #2,d0			; Ok
	rts
.index_langue: dc.b 0,1,2,0,3,4,0,2,1
	even

modpal:
	moveq #2,d0			; Ok
	rts

	; sauvegarde les valeurs du FORTH
	; reloge le RSC
	; lance form_center et conserve les coordonn‚es
	
do_param:
	bsr save_forth_values
	lea mon_rsc(pc),a0
	move.l vdipb(pc),a1
	move.l 4(a1),a1		; adresse INTIN
	move.l #'FORT',(a1)	; marqueur pour routines internes
	move.l a0,-(a6)
	move #842,d0			; rsrc_rcfix
	bsr exec_forth
	moveq #0,d0
	bsr get_tree
	lea mon_arbre(pc),a1
	move.l a0,(a1)			; conserve l'adresse
	move.l a0,-(a6)		; pour form_center
	move.l 49*24+12(a0),a1	; tedinfo de l'ann‚e
	lea annee-4(pc),a2
	move #6,(a2)+			; taille max de chaine FORTH
	move.w #'%d',(a2)+	; pr‚fixe pour d‚cimal
	move.l a2,(a1)			; fixe ma chaine pour l'‚dition de l'ann‚e
	move #345,d0			; form_center
	bsr exec_forth
	bsr get_intout
	addq.l #2,a0
	move.l a0,-(a6)		; intout+2
	move #754,d0			; get_xywh
	bsr exec_forth		
	lea coords(pc),a0
	move.l (a6)+,(a0)+	; h
	move.l (a6)+,(a0)+	; w
	move.l (a6)+,(a0)+	; y
	move.l (a6)+,(a0)+	; x
	moveq #0,d0				; OK
	rts

get_intout:
	move.l vdipb(pc),a0
	move.l 12(a0),a0		; intout	
	rts

save_forth_values:
	lea debut(pc),a0		; r‚cupŠre les donn‚es envoy‚es par MODLOAD
	lea adresse(pc),a1
	move.l -(a0),(a1)+	; adresse
	move.w -(a0),(a1)+	; handle
	move.w -(a0),(a1)+	; i_handle
	move.l -(a0),(a1)+	; aespb
	move.l -(a0),(a1)+	; vdipb
	move.l -(a0),(a1)+	; adresse variable langage.w
	rts
	; d0=code du mot FORTH … ‚x‚cuter
	
exec_forth:
	lea adresse(pc),a0
	move.l (a0),a0			; base des adresses
	lsl.w #2,d0
	move.l 0(a0,d0.w),a0	; adresse du mot
	jsr (a0)					; execute
	rts

; pile RTS/4:sndb

modexe:	
	bsr swap_ordre			; force J/M/A pendant MODEXE
	moveq #0,d0
	bsr form_dial			; r‚serve ‚cran
	move.l (a6),d0			; adresse date
	beq.s .auj				; nulle, prendre aujourd'hui
	move.l d0,a0
	tst.b (a0)				; chaine vide, prendre aujourd'hui
	bne.s .ok
.auj:
	addq.l #4,a6			; d‚pile l'argument nul
	move #510,d0
	bsr exec_forth			; tgetdate
	move #506,d0
	bsr exec_forth			; datetostr
.ok:
	move #917,d0
	bsr exec_forth			; unpackdate, jj, mm, aaaa
	bsr init					; remplit date, mois jour
.boucle_gem:
	clr.l -(a6)				; objet 0
	moveq #2,d0
	move.l d0,-(a6)		; profondeur 2
	bsr add_coords			; X, Y, W, H
	lea mon_arbre(pc),a0
	move.l (a0),-(a6)
	move #336,d0			; objc_draw
	bsr exec_forth

	moveq #49,d0
	move.l d0,-(a6)		; num‚ro de l'objet EDIT (ann‚e)
	lea mon_arbre(pc),a0
	move.l (a0),-(a6)
	move #343,d0			; form_do
	bsr exec_forth
	bsr get_intout
	move (a0),d0			; bouton de sortie
	bclr #15,d0				; en cas de double clic
	move.l mon_arbre(pc),a0
	moveq #24,d1
	muls d0,d1
	bclr #0,11(a0,d1.l)	; vire le "selected" du bouton de sortie
	moveq #-1,d5
	cmp #52,d0				; bouton "ann‚e pr‚c‚dente"
	bne.s .lb0
.lb1:
	bsr next_previous
	bra .boucle_gem
.lb0:
	moveq #1,d5
	cmp #53,d0				; bouton "ann‚e suivante"
	beq.s .lb1
	cmp #50,d0				; bouton update
	bne.s .lb2
	bsr update
	bra .boucle_gem
.lb2:
	cmp #33,d0				; bouton OK
	beq.s .fin
	cmp #34,d0				; bouton Abandon
	bne .boucle_gem		; ne devrai pas arriver... bouton inconnu?
	moveq #0,d1				; si abandon, retour z‚ro
	bra.s .exit
.fin:
	bsr get_values			; j m a sur la pile
	tst.l d0					; erreur ann‚e ou pas ?
	bne.s .termine
	lea 12(a6),a6			; d‚pile tout
	bra .boucle_gem		; et on reste sur l'interface.
.termine:
	bsr check_ordre		; selon la demande, inverse ou non J/M en M/J
	move #918,d0
	bsr exec_forth			; packdate, chaine sur la pile
	moveq #3,d1				; renvoie OK
.exit:
	move.l d1,-(sp)		
	moveq #3,d0
	bsr form_dial
	bsr swap_ordre
	move.l (sp)+,d0		; valeur retour !
	rts	
	
init:
	move.l (a6)+,d0		; ann‚e
	cmp #100,d0
	bpl.s .ok
	add #1900,d0			; en cas d'ann‚e … 2 chiffres [1980-2079]
	cmp #1980,d0
	bpl.s .ok
	add #100,d0
.ok:
	move.l #1583,d7		; v‚rifier !
	cmp.l d0,d7
	ble.s .good
	bsr erreur_annee		; <1583, on refuse
	move.l d7,d0
.good:
	move.l d0,d7
	bsr year_to_str
	move.l (a6)+,d0		; mois
	move.l d0,d6
	bsr.s set_radio_m
	bsr set_week
	bsr.s month_size
	move.l (a6)+,d0		; jour
	bsr.s set_radio_j
	bsr set_langue			; et traduit l'interface.
	rts

set_radio_j:
	move.l mon_arbre(pc),a0
	lea 32*24+11(a0),a0	; dernier state des radio boutons des jours
	moveq #30,d1
	bra.s set_radio
	
set_radio_m:
	move.l mon_arbre(pc),a0
	lea 48*24+11(a0),a0	; dernier state des radio boutons du mois
	moveq #11,d1	
set_radio:
	subq #1,d0			; de 0 … 11 ou 30
.lb0:
	bclr #0,(a0)		; par d‚faut, non s‚lectionn‚
	cmp d1,d0
	bne.s .sr1			; pas le jour voulu
	btst #3,(a0)		; bouton disabled? (au dela du nombre de jours)
	beq.s .sr0			; tout est bon, marquer !
	subq #1,d0			; au dela, donc r‚duire jour et retenter
	bra.s .sr1	
.sr0:	
	bset #0,(a0)		; selected
.sr1:
	lea -24(a0),a0
	dbf d1,.lb0
	rts 			

month_size:
	cmp #2,d6				; f‚vrier?
	bne.s .normal
	moveq #3,d0
	and d7,d0
	bne.s .normal			; pas un multiple de 4, ann‚e normale
	divs #100,d7
	swap d7
	tst d7
	bne.s .biss				; pas un siŠcle, donc bissextile
	swap d7
	and #$3,d7
	bne.s .normal			; un siŠcle mais pas multiple de 400, normal	
.biss:
	moveq #29,d6
	bra.s .suite
.normal:	
	move.b .long-1(pc,d6),d6
.suite:
	move.l mon_arbre(pc),a0
	lea 32*24+11(a0),a0	; dernier state des radio boutons des jours
	moveq #31,d0
.on_off:
	bclr #3,(a0)			; par d‚faut, bouton valide
	cmp d0,d6
	bpl.s .ms0
	bset #3,(a0)			; mais si en dessous du nombre de jours, disabled
.ms0:
	lea -24(a0),a0			; objet suivant
	subq #1,d0
	cmp #28,d0				; ne concerne que les jours 29-30-31
	bne.s .on_off	
	rts
.long: dc.b 31,28,31,30,31,30,31,31,30,31,30,31				

set_week:
	movem.l d6-d7,-(sp)
	moveq #1,d0
	move.l d0,-(a6)		; 1er
	move.l d6,-(a6)		; du mois
	move.l d7,-(a6)		; et de l'ann‚e
	move #918,d0
	bsr exec_forth			; packdate
	move #913,d0
	bsr exec_forth			; dofw
	move.l (a6)+,d0
	muls #3,d0
	lea jours(pc,d0.l),a0	; d‚but semaine
	move.l mon_arbre(pc),a1
	move.l 35*24+12(a1),a1	; chaine jours semaine
	moveq #20,d0
.sw0:
	move.b (a0)+,(a1)+
	dbf d0,.sw0
	clr.b (a1)
	movem.l (sp)+,d6-d7
	rts
jours: dc.b "Sa Di Lu Ma Me Je Ve Sa Di Lu Ma Me Je ",0

form_dial:
	move.l d0,-(a6)		; flag
	clr.l -(a6)				; x,y,w,h
	clr.l -(a6)
	clr.l -(a6)
	clr.l -(a6)
	bsr add_coords			; X, Y, W, H
	move #344,d0			; form_dial
	bsr exec_forth
	rts

add_coords:
	lea coords+16(pc),a0
	move.l -(a0),-(a6)	; X
	move.l -(a0),-(a6)	; Y
	move.l -(a0),-(a6)   ; W
	move.l -(a0),-(a6)   ; H	
	rts
	
	; d0 nø arbre
get_tree:
	lea mon_rsc(pc),a0
	add 18(a0),a0			; pointeur arbres
	lsl.l #2,d0				; par 4
	move.l 0(a0,d0.l),a0	; mon arbre!
	rts
	
year_to_str:
	lea annee+4(pc),a0
	moveq #3,d1
	clr.b (a0)				; fin de chaine
.lb0:
	divs #10,d0
	swap d0
	add.b #'0',d0
	move.b d0,-(a0)		; sort les 4 caractŠres de l'ann‚e
	clr d0
	swap d0
	dbf d1,.lb0
	rts
	
str_to_year:
	lea annee-2(pc),a0
	move.l a0,-(a6)
	move #100,d0
	bsr exec_forth			; val
	move.l #1583,d0
	cmp.l (a6),d0
	ble.s .ok
	move.l d0,(a6)
	bsr erreur_annee
	moveq #0,d0				; renvoie D0=0 si erreur
.ok:
	rts						; sinon renvoie D0=1583

get_values:
	moveq #1,d0
	bsr find_radio			; jour sur la pile
	moveq #36,d0
	bsr find_radio			; mois sur la pile
	bsr.s str_to_year		; ann‚e sur la pile, renvoie D0=0 si erreur ann‚e
	rts
	
update:
	bsr.s get_values		; j,m,a
	move.l (a6)+,d7		; a
	move.l (a6)+,d6		; m
	bsr set_week			; jours de la semaine
	bsr month_size		; r‚duit les jours possibles
	move.l (a6)+,d0		; j
	bsr set_radio_j		; si le jour ne convient pas au mois il est r‚duit
	rts

next_previous:
	move.l d5,-(sp)		; +/-1
	bsr str_to_year
	move.l (a6)+,d0
	add.l (sp)+,d0			; nouvelle ann‚e
	bsr year_to_str
	bra update

find_radio:
	move.l d0,-(sp)
	move.l d0,-(a6)		; index boite
	move.l mon_arbre(pc),-(a6)	; adresse arbre
	move #904,d0
	bsr exec_forth			; getradio
	move.l (sp)+,d0
	sub.l d0,(a6)			; ramŠne … 1 le premier ‚l‚ment (mois ou jour)
	rts

	; 1er appel force langage FORTH … 2 (JMA)
	; 2 appel, remet la valeur d'origine
	
swap_ordre:
	lea ordre2(pc),a0
	move.l langage(pc),a1
	move (a1),d0
	move (a0),(a1)
	move d0,(a0)
	rts
	
	; selon ordre demand‚ (par modinfo)
	; inverse ou non J/M au retour de modexe.
	
check_ordre:
	move ordre(pc),d0
	bne.s .fin				; <>0 donc on garde JMA
	move.l 8(a6),d0
	move.l 4(a6),8(a6)
	move.l d0,4(a6)
.fin:
	rts


	; au cas o— l'ann‚e soit avant 1583... on la refuse !
erreur_annee:
	movem.l d1-d7/a0-a3,-(sp)
	moveq #1,d0
	move.l d0,-(a6)
	move.l alerte(pc),-(a6)
	move #346,d0
	bsr exec_forth
	movem.l (sp)+,d1-d7/a0-a3
	rts


set_langue:
	move langue(pc),d0	; la langue actuelle
	muls #6,d0
	lea tab_langue(pc,d0.l),a2		; pointeur offsets
	lea textes(pc),a1
	move.l mon_arbre(pc),a0
	bsr .next
	move.l a1,34*24+12(a0)		; chaine abandon
	bsr .next
	move.l a1,50*24+12(a0)		; chaine update
	bsr .next
	move.l a1,51*24+12(a0)		; chaine Mois :
	bsr .next
	move.b (a1),37*24+12(a0)	; caractŠre Janvier
	move.b 1(a1),42*24+12(a0)	; caractŠre Juin
	move.b 2(a1),43*24+12(a0)	; caractŠre Juillet
	bsr .next
	lea jours(pc),a0
	moveq #20,d0
.lb0:
	move.b (a1)+,(a0)+			; copie de samedi … vendredi
	dbf d0,.lb0
	lea -21(a1),a1
	moveq #17,d0
.lb1:
	move.b (a1)+,(a0)+			; ajoute de samedi … jeudi
	dbf d0,.lb1
	lea -18(a1),a1
	bsr .next
	lea alerte(pc),a0
	move.l a1,(a0)					; alerte sur l'ann‚e <1583
	rts	
.next:
	moveq #0,d0
	move.b (a2)+,d0
	bmi.s .fin	
.avance:
	tst.b (a1)+
	bne.s .avance
	dbf d0,.avance
.fin:
	rts

	data

langue: dc.w 2				; d‚faut fran‡ais
ordre: dc.w 2				; d‚faut JMA
ordre2: dc.w 2				; ordre pendant modexe (conserve langagedu FORTH)

tab_langue:
	dc.b -1,3,4,4,2,5		; code 0 (et 3) anglais
	dc.b 1,4,4,1,6,2		; code 1 (et 8) allemand
	dc.b -1,4,4,3,3,3		; code 2 (et 7) fran‡ais
	dc.b 0,4,4,3,3,6		; code 4        espagnol
	dc.b 2,4,4,2,3,4		; code 5        italien
	
textes: dc.b "Abandon",0,"Abandonar",0,"Abbruch",0,"Annulla",0
	dc.b "Update",0,"Actualiser",0,"Actualizar",0,"Aktualis.",0,"Aggiorna",0
	dc.b "Month :",0,"Mois :",0,"Mes :",0,"Monat :",0,"Mese :",0
	dc.b "JJJ",0,"EJJ",0,"GGL",0
	dc.b "Sa Su Mo Tu We Th Fr ",0,"Sa Di Lu Ma Me Je Ve ",0,"Sa Do Lu Ma Mi Ju Vi ",0
	dc.b "Sa Do Lu Ma Me Gi Ve ",0,"Sa So Mo Di Mi Do Fr ",0
	dc.b "[1][ | L'ann‚e doit ˆtre | post‚rieure … 1582 ! ][ Ok ]",0
	dc.b "[1][ | The year must be | after 1582 ! ][ Ok ]",0
	dc.b "[1][ | Das Jahr muss | nach 1582 liegen ! ][ Ok ]",0
	dc.b "[1][ | L'anno deve essere | successivo al 1582 ! ][ Ok ]",0
	dc.b "[1][ | ­ El a¤o debe ser | posterior a 1582 ! ][ Ok ]",0
	even
	
mon_rsc:
	INCBIN "CALENDAR.RSC"
	even
	
	bss
	
adresse: ds.l 1
handle: ds.w 1
i_handle: ds.w 1
aespb: ds.l 1
vdipb: ds.l 1
langage: ds.l 1
coords: ds.l 4			; x,y,w,h de la boite
mon_arbre: ds.l 1
	ds.w 1				; pour la taille max: 6				
	ds.b 2				; pour le pr‚fixe %d
annee: ds.b 6			; 4 caractŠres + z‚ro
alerte: ds.l 1

	end