GOSUB begin
> PROCEDURE begin
COLOR 1
DEFFILL 1,2,4
PBOX -1,-1,641,401
res&=XBIOS(4)
IF res&=0 THEN
ALERT 1," Dit genealogie programma | werkt alleen in high | of medium resolutie ",1," OK ",ant
QUIT
ENDIF
DEFFILL ,0,0
PBOX -1,-1,640,200*res&
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
GOSUB init
GOSUB make_menu
DO
EXIT IF VAL(RIGHT$(DATE$,4))>=1990
GOSUB datum
LOOP
GOSUB main
RETURN
> FUNCTION leeftijd(oud$)
IF INSTR(RIGHT$(oud$,4),"?")<>0 THEN
IF leef! THEN
RETURN (365.25*VAL(RIGHT$(DATE$,4))+30.4375*VAL(MID$(DATE$,4,2))+VAL(LEFT$(DATE$,2)))
ELSE
RETURN (0)
ENDIF
ELSE
RETURN (365.25*VAL(RIGHT$(oud$,4))+30.4375*VAL(MID$(oud$,4,2))+VAL(LEFT$(oud$,2)))
ENDIF
ENDFUNC
> PROCEDURE main
foutlabel:
ON BREAK GOSUB quit
ON ERROR GOSUB fout
GOSUB res
GOSUB laatste
GOSUB sorteer_sel
GOSUB count_sel
DO
VOID FRE()
SHOWM
GOSUB laatste
IF last&=1
ant$=STR$(last&)+" naam"
ELSE
ant$=STR$(last&)+" namen"
ENDIF
IF sort!=TRUE THEN
sort$=" Bestand is gesorteerd! "+ant$+" in file. "
ELSE
sort$=" Bestand is (nog) niet gesorteerd! "+ant$+" in file."
ENDIF
MID$(menu1$(57),17,4)=LEFT$(STR$(select)+" ",4)
MENU menu1$()
b=0
TEXT 475,7*res&,"Records : "+STR$(last&)
IF filename$="" THEN
filename$=old$
ENDIF
old$=filename$
REPEAT
n=b
b=INSTR(n+1,filename$,"\")
UNTIL b=0
filename$=LEFT$(filename$,n)+"*.FAM"
keuze!=FALSE
record!=TRUE
REPEAT
ON MENU
ON MENU GOSUB menu
ON MENU KEY GOSUB key
LET printboolean!=FALSE
IF record!=FALSE AND ODD(INT(TIMER/200))
record!=TRUE
TEXT 475,7*res&,"Records : "+STR$(last&)+" "
ELSE IF record!=TRUE AND EVEN(INT(TIMER/200))
record!=FALSE
TEXT 475,7*res&,"Trouwdata : "+STR$(trpo-1)+" "
ENDIF
UNTIL keuze!
LOOP
RETURN
> PROCEDURE menu
keuze=MENU(0)
ON keuze GOSUB info,d,d,d,d,d,d,d,d,d,new,d,load,merge,save,ssave,d,quit,d,d,add,delete,edit,ver,trouw,d,see,voor,plaatje,d,d,dia1,dia2,dia3,fam,d,sorteer,copy,stats,d,d,al,al,al,al,al,al,al,al,al,d,kind,brzs,mot,d,d,xinf,d,list,llist,llrec,d,inv,res
keuze!=TRUE
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
RETURN
> PROCEDURE key
SELECT MENU(14)/256
CASE 28
GOSUB info
CASE 47
GOSUB voor
CASE 121
GOSUB dia2
CASE 122
GOSUB dia3
CASE 123
GOSUB fam
CASE 49
GOSUB new
CASE 38
GOSUB load
CASE 50
GOSUB merge
CASE 31
GOSUB save
CASE 16
GOSUB quit
CASE 30
GOSUB add
CASE 32
GOSUB delete
CASE 46
GOSUB edit
CASE 20
GOSUB trouw
CASE 44
GOSUB see
CASE 25
GOSUB ssave
CASE 120
GOSUB dia1
CASE 24
GOSUB sorteer
CASE 35
GOSUB copy
CASE 19
GOSUB res
CASE 23
GOSUB inv
ENDSELECT
keuze!=TRUE
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
RETURN
> PROCEDURE xinf
ALERT 3," | Onder uitvoer worden alleen | geselecteerde records uit- | gevoerd. ",1," O.K. ",ant
RETURN
> PROCEDURE d
RETURN
> PROCEDURE info
ALERT 1," Genealogie v2.1 | Door P. M. Bloemendaal | | Copyright START 1990 ",1," OK ",ant
RETURN
> PROCEDURE new
ALERT 2," | Bestand wordt gewist.",1," OK | Cancel ",ant
IF ant=1 THEN
trpo=1
begpri=1
select=0
ARRAYFILL volg&(),0
ARRAYFILL trouw&(),0
ARRAYFILL index&(),0
FOR n&=1 TO max
naam$(n&)=""
NEXT n&
GOSUB laatste
ENDIF
RETURN
> PROCEDURE laatste_file
IF laatste_file$="" THEN
path$=SPACE$(100)
~GEMDOS(71,L:VARPTR(path$),0)
WHILE RIGHT$(path$,1)=" "
path$=LEFT$(path$,LEN(path$)-1)
WEND
path$=LEFT$(path$,LEN(path$)-1)
path$=CHR$(GEMDOS(25)+65)+":"+path$+"\"
laatste_file$="ONBEKEND"
ELSE
dummy%=RINSTR(laatste_file$,"\")
laatste_file$=RIGHT$(laatste_file$,LEN(laatste_file$)-dummy%)
ENDIF
RETURN
> PROCEDURE load
GOSUB laatste_file
GOSUB open_box("Laad een bestand")
FILESELECT filename$,laatste_file$,filename$
GOSUB close_box
IF EXIST(filename$) THEN
ARRAYFILL volg&(),0
ARRAYFILL trouw&(),0
ARRAYFILL index&(),0
laatste_file$=filename$
sort!=FALSE
begpri=1
trpo=1
select=0
ARRAYFILL volg&(),0
FOR n&=1 TO max
naam$(n&)=""
NEXT n&
GOSUB open_bar(filename$+" wordt geladen")
OPEN "i",#1,filename$
INPUT #1,dummy&
dummy&=INP(#1)
CLOSE #1
IF dummy&<48 THEN
OPEN "i",#1,filename$
INPUT #1;last&
FOR n&=1 TO last&
volg&(n&)=CVI(INPUT$(2,#1))
naam$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
voor$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
ges$(n&)=INPUT$(1,#1)
geb$(n&)=INPUT$(10,#1)
ov$(n&)=INPUT$(10,#1)
op$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
plaats$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
beroep$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
FOR b&=1 TO maxrel
index&(n&,b&,1)=CVI(INPUT$(2,#1))
index&(n&,b&,2)=CVI(INPUT$(2,#1))
EXIT IF index&(n&,b&,1)=0
NEXT b&
GOSUB bar(last&,n&)
NEXT n&
GOSUB close_bar
IF NOT EOF(#1) THEN
GOSUB open_bar("De trouwdata wordt nageladen")
INPUT #1;trpo
FOR n&=1 TO trpo-1
trouw&(n&,1)=CVI(INPUT$(2,#1))
trouw&(n&,2)=CVI(INPUT$(2,#1))
trouw$(n&)=INPUT$(10,#1)
GOSUB bar(trpo,n&)
NEXT n&
GOSUB close_bar
ENDIF
CLOSE #1
PRINT CHR$(7);
ELSE
DEFMOUSE 2
sort!=FALSE
begpri=1
ARRAYFILL volg%(),0
FOR n%=1 TO max
naam$(n%)=""
NEXT n%
GOSUB open_bar(filename$+" (v1.0 bestand) wordt geladen")
OPEN "i",#1,filename$
INPUT #1;last&
FOR n&=1 TO last&
INPUT #1;volg&(n&)
INPUT #1;naam$(n&)
INPUT #1;voor$(n&)
INPUT #1;ges$(n&)
INPUT #1;geb$(n&)
INPUT #1;ov$(n&)
INPUT #1;op$(n&)
INPUT #1;plaats$(n&)
INPUT #1;beroep$(n&)
FOR b&=1 TO maxrel
INPUT #1;index&(n&,b&,1)
INPUT #1;index&(n&,b&,2)
EXIT IF index&(n&,b&,1)=0
NEXT b&
GOSUB bar(last&,n&)
NEXT n&
CLOSE #1
DEFMOUSE 0
GOSUB close_bar
PRINT CHR$(7)
ENDIF
ENDIF
RETURN
> PROCEDURE merge
GOSUB laatste
IF last&=1 THEN
ALERT 3," | Er is nog geen bestand | ingeladen. ",1," O.K. ",ant
ELSE
GOSUB laatste_file
GOSUB open_box("Voeg bestand toe")
FILESELECT filename$,laatste_file$,filename$
GOSUB close_box
IF EXIST(filename$) THEN
laatste_file$=filename$
GOSUB laatste
GOSUB maakvolg
INC last&
begpri=1
select=0
OPEN "i",#1,filename$
INPUT #1;le
GOSUB open_bar(filename$+" wordt toegevoegd")
FOR n&=last& TO last&+le-1
volg&(n&)=CVI(INPUT$(2,#1))
naam$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
voor$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
ges$(n&)=INPUT$(1,#1)
geb$(n&)=INPUT$(10,#1)
ov$(n&)=INPUT$(10,#1)
op$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
plaats$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
beroep$(n&)=INPUT$(CVI(INPUT$(2,#1)),#1)
FOR b&=1 TO maxrel
index&(n&,b&,1)=CVI(INPUT$(2,#1))
index&(n&,b&,2)=CVI(INPUT$(2,#1))
EXIT IF index&(n&,b&,1)=0
NEXT b&
GOSUB bar(last&+le-1,n&)
NEXT n&
GOSUB close_bar
IF NOT EOF(#1) THEN
GOSUB open_bar("Trouwdata wordt toegevoegd")
INPUT #1;leo
FOR n&=trpo TO trpo+leo-2
trouw&(n&,1)=CVI(INPUT$(2,#1))
trouw&(n&,2)=CVI(INPUT$(2,#1))
trouw$(n&)=INPUT$(10,#1)
GOSUB bar(trpo+leo-1,n&)
NEXT n&
GOSUB close_bar
ENDIF
CLOSE #1
GOSUB open_bar("Namen worden tussengevoegd")
FOR n&=last& TO last&+le-1
volg&(n&)=volg&(n&)+volg
FOR b&=1 TO maxrel
index&(n&,b&,1)=index&(n&,b&,1)+volg
NEXT b&
GOSUB bar(le-1,n&-last&)
NEXT n&
GOSUB close_bar
FOR n&=trpo TO trpo+leo-1
trouw&(n&,1)=trouw&(n&,1)+volg
trouw&(n&,2)=trouw&(n&,2)+volg
NEXT n&
trpo=trpo+leo-1
MENU KILL
sort!=FALSE
CLS
GOSUB sorteer
GOSUB laatste
HIDEM
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE save
GOSUB laatste_file
GOSUB open_box("Bewaar een bestand")
FILESELECT filename$,laatste_file$,filename$
GOSUB close_box
IF filename$<>"" THEN
IF INSTR(filename$,".")=0 THEN
filename$=filename$+".FAM"
ENDIF
laatste_file$=filename$
GOSUB laatste
GOSUB open_bar(filename$+" wordt gesaved")
OPEN "o",#1,filename$
PRINT #1;last&
FOR n&=1 TO last&
PRINT #1;MKI$(volg&(n&));
PRINT #1;MKI$(LEN(naam$(n&)));naam$(n&);
PRINT #1;MKI$(LEN(voor$(n&)));voor$(n&);
PRINT #1;ges$(n&);
PRINT #1;LEFT$(geb$(n&)+SPACE$(10),10);
PRINT #1;LEFT$(ov$(n&)+SPACE$(10),10);
PRINT #1;MKI$(LEN(op$(n&)));op$(n&);
PRINT #1;MKI$(LEN(plaats$(n&)));plaats$(n&);
PRINT #1;MKI$(LEN(beroep$(n&)));beroep$(n&);
FOR b&=1 TO maxrel
PRINT #1;MKI$(index&(n&,b&,1));MKI$(index&(n&,b&,2));
EXIT IF index&(n&,b&,1)=0
NEXT b&
~LOF(#1)
GOSUB bar(last&,n&)
NEXT n&
GOSUB close_bar
IF trpo>1 THEN
GOSUB open_bar("De trouw data wordt gesaved")
PRINT #1;trpo
FOR n&=1 TO trpo-1
PRINT #1;MKI$(trouw&(n&,1));
PRINT #1;MKI$(trouw&(n&,2));
PRINT #1;LEFT$(trouw$(n&)+SPACE$(10),10);
GOSUB bar(trpo,n&)
~LOF(#1)
NEXT n&
GOSUB close_bar
ENDIF
CLOSE #1
PRINT CHR$(7);
ENDIF
RETURN
> PROCEDURE ssave
IF screen$<>"" THEN
IF res&=1 THEN
res$="PI2"
ELSE
res$="PI3"
ENDIF
GOSUB laatste_file
GOSUB open_box("Bewaar plaatje")
FILESELECT LEFT$(filename$,LEN(filename$)-5)+"*."+res$,laatste_file$,filename$
GOSUB close_box
IF filename$<>"" THEN
IF INSTR(filename$,".")=0 THEN
filename$=filename$+"."+res$
ENDIF
laatste_file$=filename$
DEFMOUSE 2
OPEN "o",#1,filename$
OUT #1,0
OUT #1,XBIOS(4)
FOR n=&HFF8240 TO &HFF825F
OUT #1,PEEK(n)
NEXT n
PRINT #1;screen$
CLOSE #1
DEFMOUSE 0
ENDIF
ELSE
ALERT 3," | Nog geen diagram gemaakt. ",1," O.K. ",ant
ENDIF
RETURN
> PROCEDURE quit
ALERT 2," Wilt U het programma | nu verlaten? ",2," Ja | Nee ",ant
IF ant=1 THEN
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
~RSRC_FREE()
EDIT
ENDIF
RETURN
> PROCEDURE add
MENU KILL
HIDEM
CLS
GOSUB laatste
IF last&>=max THEN
ALERT 3," | | Het geheugen is vol ",1," Sorry ",ant
ELSE
CLR innaam$,invoor$,inges$,ingeb$,inov$,inberoep$,inplaats$,inop$
FOR m=1 TO maxrel
inindex&(m,1)=0
inindex&(m,2)=0
NEXT m
sort!=FALSE
FOR m=1 TO last&+1
EXIT IF naam$(m)=""
NEXT m
GOSUB maakvolg
'
~FORM_CENTER(dia1%,x&,y&,w&,h&)
CHAR{{OB_SPEC(dia1%,achter&)}}=""
CHAR{{OB_SPEC(dia1%,voor&)}}=""
CHAR{{OB_SPEC(dia1%,geslacht&)}}=""
CHAR{{OB_SPEC(dia1%,beroep&)}}=""
CHAR{{OB_SPEC(dia1%,gjaar&)}}=""
CHAR{{OB_SPEC(dia1%,gmaand&)}}=""
CHAR{{OB_SPEC(dia1%,gdag&)}}=""
CHAR{{OB_SPEC(dia1%,ojaar&)}}=""
CHAR{{OB_SPEC(dia1%,omaand&)}}=""
CHAR{{OB_SPEC(dia1%,odag&)}}=""
CHAR{{OB_SPEC(dia1%,plaats&)}}=""
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
DO
~OBJC_DRAW(dia1%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia1%,0)
SELECT BCLR(a%,15)
CASE info&
ALERT 1," Genealogie v2.1 | Door P. M. Bloemendaal | | Copyright START 1990 ",1," OK ",ant
OB_STATE(dia1%,info&)=BCLR(OB_STATE(dia1%,info&),0)
CASE ok&
inges$=CHAR{{OB_SPEC(dia1%,geslacht&)}}
innaam$=CHAR{{OB_SPEC(dia1%,achter&)}}
inges$=UPPER$(inges$)
ingmaand$=CHAR{{OB_SPEC(dia1%,gmaand&)}}
ingdag$=CHAR{{OB_SPEC(dia1%,gdag&)}}
inomaand$=CHAR{{OB_SPEC(dia1%,omaand&)}}
inodag$=CHAR{{OB_SPEC(dia1%,odag&)}}
IF (inges$<>"M" AND inges$<>"V") OR innaam$="" OR VAL(gmaand$)>12 OR VAL(omaan$)>12 OR VAL(odag$)>31 OR VAL(gdag$)>31 THEN
PRINT CHR$(7);
a%=0
ENDIF
OB_STATE(dia1%,ok&)=BCLR(OB_STATE(dia1%,ok&),0)
CASE opm&
OB_STATE(dia1%,opm&)=BCLR(OB_STATE(dia1%,opm&),0)
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
GOSUB opmerking
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
ENDSELECT
EXIT IF a%=ok& OR a%=cancel&
LOOP
SHOWM
IF a%=cancel& THEN
OB_STATE(dia1%,cancel&)=BCLR(OB_STATE(dia1%,cancel&),0)
ENDIF
IF a%=ok& THEN
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
innaam$=CHAR{{OB_SPEC(dia1%,achter&)}}
invoor$=CHAR{{OB_SPEC(dia1%,voor&)}}
inges$=CHAR{{OB_SPEC(dia1%,geslacht&)}}
inges$=UPPER$(inges$)
inberoep$=CHAR{{OB_SPEC(dia1%,beroep&)}}
ingjaar$=CHAR{{OB_SPEC(dia1%,gjaar&)}}
ingmaand$=CHAR{{OB_SPEC(dia1%,gmaand&)}}
ingdag$=CHAR{{OB_SPEC(dia1%,gdag&)}}
inojaar$=CHAR{{OB_SPEC(dia1%,ojaar&)}}
inomaand$=CHAR{{OB_SPEC(dia1%,omaand&)}}
inodag$=CHAR{{OB_SPEC(dia1%,odag&)}}
inplaats$=CHAR{{OB_SPEC(dia1%,plaats&)}}
'
dag$=RIGHT$("00"+ingdag$,2)
maand$=RIGHT$("00"+ingmaand$,2)
jaar$=RIGHT$("????"+ingjaar$,4)
datum$=dag$+"/"+maand$+"/"+jaar$
ingeb$=datum$
dag$=RIGHT$("00"+inodag$,2)
maand$=RIGHT$("00"+inomaand$,2)
jaar$=RIGHT$("????"+inojaar$,4)
datum$=dag$+"/"+maand$+"/"+jaar$
inov$=datum$
'
GOSUB relaties
GOSUB laatzien
GOSUB kies("Klopt dit allemaal?")
IF ant=1 THEN
GOSUB enter
ENDIF
ENDIF
CLS
ENDIF
RETURN
> PROCEDURE opmerking
CLS
HIDEM
IF inop$="" THEN
regel$=SPACE$(1600)
ELSE
regel$=LEFT$(inop$+SPACE$(1600),1600)
FOR gh%=1 TO 20
PRINT AT(1,gh%);MID$(inop$,80*(gh%-1)+1,80)
NEXT gh%
ENDIF
x%=1
y%=1
po%=-1
ex!=FALSE
DO
under%=ASC(MID$(regel$,80*(y%-1)+x%,1))
PRINT AT(x%,y%);"p";CHR$(under%);"q"
CLR key&
key&=INP(2)
SELECT key&
CASE 200
PRINT AT(x%,y%);CHR$(under%)
DEC y%
CASE 208
PRINT AT(x%,y%);CHR$(under%)
INC y%
CASE 203
PRINT AT(x%,y%);CHR$(under%)
DEC x%
CASE 205
PRINT AT(x%,y%);CHR$(under%)
INC x%
CASE 32
PRINT AT(x%,y%);CHR$(key&)
MID$(regel$,80*(y%-1)+x%,1)=CHR$(key&)
po%=x%
INC x%
CASE 33 TO 126
PRINT AT(x%,y%);CHR$(key&)
MID$(regel$,80*(y%-1)+x%,1)=CHR$(key&)
INC x%
CASE 8
PRINT AT(x%,y%);" "
DEC x%
CASE 13
PRINT AT(x%,y%);CHR$(under%)
x%=1
INC y%
CASE 27
ex!=TRUE
CASE 31
FOR n%=y% TO 19
MID$(regel$,80*(n%-1)+1,80)=MID$(regel$,80*n%+1,80)
PRINT AT(1,n%);MID$(regel$,80*(n%-1)+1,80)
NEXT n%
MID$(regel$,19*80+1,80)=SPACE$(80)
PRINT AT(1,20);SPACE$(80)
x%=1
CASE 166
GOSUB open_box("Laad ASCII bestand")
FILESELECT "\*.*","",ifile$
GOSUB close_box
IF EXIST(ifile$) THEN
CLR regel$
CLS
DEFMOUSE 2
OPEN "i",#1,ifile$
flag!=FALSE
WHILE (NOT EOF(#1)) AND LEN(regel$)<1600
k=INP(#1)
IF k=13 OR k=10 THEN
IF flag!=TRUE THEN
flag!=FALSE
ELSE
regel$=LEFT$(regel$+SPACE$(80),80*(INT(LEN(regel$)/80)+1))
flag!=TRUE
ENDIF
ELSE
flag!=FALSE
regel$=regel$+CHR$(k)
ENDIF
WEND
CLOSE #1
DEFMOUSE 0
GOSUB wrap(regel$)
PRINT AT(1,1);regel$
x%=1
y%=1
under%=ASC(MID$(regel$,80*(y%-1)+x%,1))
regel$=LEFT$(regel$+SPACE$(1600),1600)
ENDIF
ENDSELECT
IF x%=81 AND y%<20 THEN
help$=MID$(regel$,80*(y%-1)+po%+1,81-po%)
MID$(regel$,80*(y%-1)+po%+1,81-po%)=SPACE$(81-po%)
MID$(regel$,80*y%+1,81-po%)=help$
PRINT AT(po%+1,y%);SPACE$(81-po%)
PRINT AT(1,y%+1);help$
INC y%
x%=81-po%
ENDIF
IF x%=0 AND y%>1 THEN
DEC y%
x%=81
ENDIF
IF x%=0 THEN
x%=1
PRINT CHR$(7);
ENDIF
IF y%>20 THEN
y%=20
PRINT CHR$(7);
ENDIF
IF y%<1 THEN
y%=1
PRINT CHR$(7)
ENDIF
EXIT IF ex!
LOOP
PRINT AT(x%,y%);CHR$(under%)
PRINT AT(1,1);regel$
FOR n&=LEN(regel$) DOWNTO 1
EXIT IF MID$(regel$,n&,1)<>" "
NEXT n&
regel$=LEFT$(regel$,n&)
inop$=regel$
CLS
DEFFILL 1,2,4
PBOX -1,-1,641,401
SHOWM
RETURN
> PROCEDURE wrap(string$)
DEFMOUSE 2
FOR n&=LEN(string$) DOWNTO 1
EXIT IF MID$(string$,n&,1)<>" "
NEXT n&
string$=LEFT$(string$,n&)
CLR uit$
CLR woord$
IF string$<>"" THEN
FOR n&=1 TO LEN(string$)
IF MID$(string$,n&,1)<>" " THEN
woord$=woord$+MID$(string$,n&,1)
ELSE
IF INT(LEN(uit$+" "+woord$)/80)>INT(LEN(uit$)/80) THEN
WHILE FRAC(LEN(uit$)/80)<>0
uit$=uit$+" "
WEND
uit$=uit$+woord$
CLR woord$
ELSE
uit$=uit$+woord$+" "
CLR woord$
ENDIF
ENDIF
NEXT n&
IF INT(LEN(uit$+" "+woord$)/80)>INT(LEN(uit$)/80) THEN
WHILE FRAC(LEN(uit$)/80)<>0
uit$=uit$+" "
WEND
uit$=uit$+woord$
ELSE
uit$=uit$+woord$+" "
ENDIF
ELSE
uit$=string$
ENDIF
FOR n&=LEN(uit$) DOWNTO 1
EXIT IF MID$(uit$,n&,1)<>" "
NEXT n&
uit$=LEFT$(uit$,n&)
inop$=uit$
DEFMOUSE 0
RETURN
> PROCEDURE relaties
ARRAYFILL inindex&(),0
SHOWM
DO
GOSUB pick(" Geef een relatie aan van: ",innaam$+", "+invoor$+" "+ingeb$)
EXIT IF index=0
PRINT
PRINT innaam$+", "+invoor$+" "+ingeb$
PRINT "is een:"
PRINT
PRINT
IF inges$="M" THEN
PRINT " 1. Vader"
ELSE
PRINT " 1. Moeder"
ENDIF
PRINT
IF inges$="M" THEN
PRINT " 2. Zoon"
ELSE
PRINT " 2. Dochter"
ENDIF
PRINT
IF inges$="M" THEN
PRINT " 3. Echtgenoot"
ELSE
PRINT " 3. Echtgenote"
ENDIF
PRINT
PRINT " 4. Geen van deze"
PRINT
PRINT
PRINT "van ";naam$(nummer%)+", "+voor$(nummer%)+" "+geb$(nummer%)
FOR n=1 TO 4
BOX 2,res&*(16*n+22),150,res&*(16*n+32)
NEXT n
ke=0
REPEAT
k$=INKEY$
IF ASC(k$)>=49 AND ASC(k$)<=53 THEN
ke=VAL(k$)
ENDIF
MOUSE x,y,k
IF k=1 AND x>2 AND x<150 THEN
FOR b=1 TO 4
IF y>res&*(16*b+22) AND y<res&*(16*b+32) THEN
ke=b
ENDIF
NEXT b
ENDIF
UNTIL ke>=1 AND ke<=4
GRAPHMODE 3
PBOX 2,res&*(16*ke+22),150,res&*(16*ke+32)
GRAPHMODE 1
REPEAT
UNTIL MOUSEK=0
IF RIGHT$(ingeb$,4)<>"????" AND RIGHT$(geb$(nummer%),4)<>"????" THEN
ant=1
jr1%=@leeftijd(ingeb$)
jr2%=@leeftijd(geb$(nummer%))
IF ke=1 AND jr2%-jr1%<7305 THEN
ALERT 2," | Het leeftijdsverschil tussen | ouder en kind is minder | dan 20 jaar ! ",1," Voer in | Cancel ",ant
ENDIF
IF ke=2 AND jr1%-jr2%<7305 THEN
ALERT 2," | Het leeftijdsverschil tussen | ouder en kind is minder | dan 20 jaar ! ",1," Voer in | Cancel ",ant
ENDIF
IF (ke=1 OR ke=2) AND ABS(jr1%-jr2%)>18262.5 THEN
ALERT 2," | Het leeftijdsverschil tussen | ouder en kind is meer | dan 50 jaar ! ",1," Voer in | Cancel ",ant
ENDIF
IF ke=3 AND ABS(jr1%-jr2%)>7305 THEN
ALERT 2," | Het leeftijdsverschil tussen | de partners is meer dan | 20 jaar ! ",1," Voer in | Cancel ",ant
ENDIF
IF ant=2 THEN
ke=4
ENDIF
ENDIF
IF inges$=ges$(nummer%) AND ke=3 THEN
ALERT 1," Ik ben tegen discriminatie, | maar homofiele relaties | zijn in dit programma | niet toegestaan.",1," Sorry ",ant
ant=2
ENDIF
IF ke<>4 THEN
FOR b=1 TO maxrel
EXIT IF inindex&(b,2)=0
NEXT b
IF b>maxrel THEN
ALERT 3," | Maximaal "+STR$(maxrel)+" relaties | per persoon ",1," O.K. ",ant
ELSE
inindex&(b,2)=ke
inindex&(b,1)=index
ENDIF
ENDIF
LOOP
RETURN
> PROCEDURE enter
volg&(m)=volg
naam$(m)=innaam$
voor$(m)=invoor$
ges$(m)=inges$
geb$(m)=ingeb$
ov$(m)=inov$
beroep$(m)=inberoep$
plaats$(m)=inplaats$
op$(m)=inop$
FOR b=1 TO maxrel
index&(m,b,1)=inindex&(b,1)
index&(m,b,2)=inindex&(b,2)
NEXT b
sort!=FALSE
CLS
RETURN
> PROCEDURE pick_graph
CLS
PRINT title$
PRINT infow$
prmax=15
DEFFILL 1,2,4
PBOX 0,res&*16,639,res&*174
DEFFILL ,0,0
PBOX 3,res&*28,636,res&*162
DEFFILL 1,0
PBOX 313,res&*26,326,res&*18
PBOX 313,res&*172,326,res&*164
DEFFILL ,1,1
TEXT 316,res&*23,CHR$(1)
TEXT 316,res&*169,CHR$(2)
RETURN
> PROCEDURE pick(title$,infow$)
GOSUB pick_graph
RBOX 50,res&*180,150,res&*195
RBOX 48,res&*179,152,res&*196
RBOX 490,res&*180,590,res&*195
TEXT 85,res&*190,"Zoek"
TEXT 515,res&*190,"Sorteer"
index=0
GOSUB laatste
np!=TRUE
DO
SHOWM
IF np! THEN
GOSUB print(begpri)
ENDIF
MOUSE x,y,k
IF k=1 THEN
IF y>res&*16 AND y<res&*28 THEN
begpri=MAX(1,begpri-prmax-1)
np!=TRUE
ENDIF
IF y>res&*162 AND y<res&*174 THEN
begpri=MIN(last&,begpri+prmax+1)
np!=TRUE
ENDIF
IF y>res&*29 AND y<res&*162 THEN
in=(y-(res&*32))/(res&*8)
IF prindex&(in)<>0 THEN
nummer%=prindex&(in)
index=volg&(nummer%)
PRINT CHR$(27);"p"
pr$=LEFT$(naam$(nummer%)+", "+voor$(nummer%)+" "+STRING$(65,"-"),65)+" "+geb$(nummer%)+" "+ges$(nummer%)
PRINT AT(2,in+5);pr$
PRINT CHR$(27);"q"
ENDIF
ENDIF
IF y>res&*180 AND y<res&*195 THEN
IF x>50 AND x<150 THEN
GOSUB zoek
ENDIF
IF x>490 AND x<590 THEN
GOSUB sorteer
np!=TRUE
ENDIF
ENDIF
ENDIF
IF GEMDOS(11)<>0 THEN
key&=INP(2)
ENDIF
IF key&=13 THEN
GOSUB zoek
ENDIF
IF key&=199 THEN
IF begpri=1 THEN
begpri=last&
ELSE
begpri=1
ENDIF
np!=TRUE
ENDIF
CLR key&
EXIT IF index<>0 OR k=2
LOOP
REPEAT
UNTIL MOUSEK=0
CLS
begpri=MIN(last&,MAX(1,nummer%-9))
IF index=0 THEN
nummer%=0
ENDIF
RETURN
> PROCEDURE zoek
PRINT AT(24,23);"Achternaam : ";
FORM INPUT 16,zoek$
PRINT AT(24,24);"Geboortejaar : ";
FORM INPUT 4,zoek1$
langst=MIN(10,LEN(zoek$))
FOR n=1 TO last&
EXIT IF LEFT$(UPPER$(naam$(n)),langst)=LEFT$(UPPER$(zoek$),langst)
NEXT n
IF n<=last& THEN
begpri=n
IF zoek1$<>"" THEN
FOR nmb&=n TO last&
EXIT IF LEFT$(UPPER$(naam$(nmb&)),langst)=LEFT$(UPPER$(zoek$),langst) AND RIGHT$(geb$(nmb&),4)=zoek1$
NEXT nmb&
IF nmb&<=last& THEN
n=nmb&
begpri=n
ENDIF
ENDIF
ELSE
FOR n=1 TO last&
EXIT IF LEFT$(UPPER$(naam$(n)),langst)>LEFT$(UPPER$(zoek$),langst)
NEXT n
begpri=MAX(1,n-1)
ENDIF
np!=TRUE
PRINT AT(24,23);SPACE$(31)
PRINT AT(24,24);SPACE$(31)
RETURN
> PROCEDURE print(begin)
np!=FALSE
ARRAYFILL prindex&(),0
FOR n=begpri TO begpri+prmax
IF naam$(n)<>"" THEN
pr$=LEFT$(naam$(n)+", "+voor$(n)+" "+STRING$(65,"-"),65)+" "+geb$(n)+" "+ges$(n)
prindex&(n-begpri)=n
PRINT AT(2,n-begpri+5);pr$
ELSE
PRINT AT(2,n-begpri+5);SPACE$(78)
ENDIF
NEXT n
RETURN
> PROCEDURE edit
MENU KILL
CLS
GOSUB pick(" Welk persoon wilt U veranderen? ",sort$)
IF nummer%<>0 THEN
CLR innaam$,invoor$,inges$,ingeb$,inov$,inberoep$,inplaats$,inop$
FOR m=1 TO maxrel
inindex&(m,1)=0
inindex&(m,2)=0
NEXT m
m=nummer%
GOSUB vul_invoer
CLS
'
' ~FORM_CENTER(dia1%,xdia1&,ydia1&,wdia1&,hdia1&)
' ~FORM_DIAL(0,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
~FORM_DIAL(1,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
CHAR{{OB_SPEC(dia1%,achter&)}}=innaam$
CHAR{{OB_SPEC(dia1%,voor&)}}=invoor$
CHAR{{OB_SPEC(dia1%,geslacht&)}}=inges$
CHAR{{OB_SPEC(dia1%,beroep&)}}=inberoep$
CHAR{{OB_SPEC(dia1%,plaats&)}}=inplaats$
IF RIGHT$(ingeb$,4)="????" THEN
CHAR{{OB_SPEC(dia1%,gjaar&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,gjaar&)}}=RIGHT$(ingeb$,4)
ENDIF
IF MID$(ingeb$,4,2)="00" THEN
CHAR{{OB_SPEC(dia1%,gmaand&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,gmaand&)}}=MID$(ingeb$,4,2)
ENDIF
IF LEFT$(ingeb$,2)="00" THEN
CHAR{{OB_SPEC(dia1%,gdag&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,gdag&)}}=LEFT$(ingeb$,2)
ENDIF
IF RIGHT$(inov$,4)="????" THEN
CHAR{{OB_SPEC(dia1%,ojaar&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,ojaar&)}}=RIGHT$(inov$,4)
ENDIF
IF MID$(inov$,4,2)="00" THEN
CHAR{{OB_SPEC(dia1%,omaand&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,omaand&)}}=MID$(inov$,4,2)
ENDIF
IF LEFT$(inov$,2)="00" THEN
CHAR{{OB_SPEC(dia1%,odag&)}}=""
ELSE
CHAR{{OB_SPEC(dia1%,odag&)}}=LEFT$(inov$,2)
ENDIF
DO
~OBJC_DRAW(dia1%,0,7,xdia1&,ydia1&,wdia1&,hdia1&)
a%=FORM_DO(dia1%,0)
SELECT BCLR(a%,15)
CASE info&
ALERT 1," Genealogie v2.1 | Door P. M. Bloemendaal | | Copyright START 1990 ",1," OK ",ant
OB_STATE(dia1%,info&)=BCLR(OB_STATE(dia1%,info&),0)
CASE ok&
inges$=CHAR{{OB_SPEC(dia1%,geslacht&)}}
innaam$=CHAR{{OB_SPEC(dia1%,achter&)}}
inges$=UPPER$(inges$)
ingmaand$=CHAR{{OB_SPEC(dia1%,gmaand&)}}
ingdag$=CHAR{{OB_SPEC(dia1%,gdag&)}}
inomaand$=CHAR{{OB_SPEC(dia1%,omaand&)}}
inodag$=CHAR{{OB_SPEC(dia1%,odag&)}}
IF (inges$<>"M" AND inges$<>"V") OR innaam$="" OR VAL(gmaand$)>12 OR VAL(omaan$)>12 OR VAL(odag$)>31 OR VAL(gdag$)>31 THEN
PRINT CHR$(7);
a%=0
ENDIF
OB_STATE(dia1%,ok&)=BCLR(OB_STATE(dia1%,ok&),0)
CASE opm&
OB_STATE(dia1%,opm&)=BCLR(OB_STATE(dia1%,opm&),0)
~FORM_DIAL(2,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
~FORM_DIAL(3,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
GOSUB opmerking
~FORM_DIAL(0,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
~FORM_DIAL(1,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
ENDSELECT
EXIT IF a%=ok& OR a%=cancel&
LOOP
SHOWM
IF a%=cancel& THEN
OB_STATE(dia1%,cancel&)=BCLR(OB_STATE(dia1%,cancel&),0)
ENDIF
IF a%=ok& THEN
~FORM_DIAL(2,320,200,20,20,xdia1&,ydia1&,wdia1&,hdia1&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
innaam$=CHAR{{OB_SPEC(dia1%,achter&)}}
invoor$=CHAR{{OB_SPEC(dia1%,voor&)}}
inges$=CHAR{{OB_SPEC(dia1%,geslacht&)}}
inges$=UPPER$(inges$)
inberoep$=CHAR{{OB_SPEC(dia1%,beroep&)}}
ingjaar$=CHAR{{OB_SPEC(dia1%,gjaar&)}}
ingmaand$=CHAR{{OB_SPEC(dia1%,gmaand&)}}
ingdag$=CHAR{{OB_SPEC(dia1%,gdag&)}}
inojaar$=CHAR{{OB_SPEC(dia1%,ojaar&)}}
inomaand$=CHAR{{OB_SPEC(dia1%,omaand&)}}
inodag$=CHAR{{OB_SPEC(dia1%,odag&)}}
inplaats$=CHAR{{OB_SPEC(dia1%,plaats&)}}
'
dag$=RIGHT$("00"+ingdag$,2)
maand$=RIGHT$("00"+ingmaand$,2)
jaar$=RIGHT$("????"+ingjaar$,4)
datum$=dag$+"/"+maand$+"/"+jaar$
ingeb$=datum$
dag$=RIGHT$("00"+inodag$,2)
maand$=RIGHT$("00"+inomaand$,2)
jaar$=RIGHT$("????"+inojaar$,4)
datum$=dag$+"/"+maand$+"/"+jaar$
inov$=datum$
'
CLS
GOSUB kies("Familie relaties van "+innaam$+" "+invoor$+" veranderen?")
IF ant=1 THEN
ALERT 1," Alle familie relaties moeten | opnieuw worden ingevoerd.",1," Ga door | Cancel ",ant
IF ant=1 THEN
GOSUB relaties
ENDIF
ENDIF
GOSUB laatzien
GOSUB kies("Klopt dit allemaal?")
IF ant=1 THEN
GOSUB enter
ENDIF
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE delete
MENU KILL
CLS
~FORM_CENTER(dia3%,x&,y&,w&,h&)
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
DO
~OBJC_DRAW(dia3%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia3%,0)
EXIT IF a%=del& OR a%=spec&
LOOP
SHOWM
IF a%=del& THEN
OB_STATE(dia3%,del&)=BCLR(OB_STATE(dia3%,del&),0)
ENDIF
IF a%=spec& THEN
OB_STATE(dia3%,spec&)=BCLR(OB_STATE(dia3%,spec&),0)
ENDIF
ant%=a%
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
GOSUB pick(" Welke naam wilt U uit het bestand verwijderen? ",sort$)
IF nummer%<>0 THEN
GOSUB vul_invoer
GOSUB laatzien
GOSUB kies("Wilt U deze naam verwijderen?")
CLS
IF ant=1 THEN
CLS
GOSUB kies("Printer aan ?")
IF ant=1 THEN
GOSUB printer
ENDIF
CLS
HIDEM
GOSUB laatste
begpri=1
ant=0
IF ant%=del& THEN
GOSUB delete1
ELSE
ALERT 3," | Er wordt een hele tak uit | de stamboom verwijderd | Wilt U doorgaan ?",1," Ja | Nee ",ant
IF ant=1 THEN
GOSUB delete2(nummer%)
ENDIF
ENDIF
sort!=FALSE
IF ant<>2 THEN
GOSUB sorteer
PRINT
PRINT CHR$(7);
PRINT " Druk op een toets."
REPEAT
UNTIL MOUSEK<>0 OR INKEY$<>""
ENDIF
SHOWM
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE delete1
IF ant=1 THEN
IF printboolean!=TRUE
GOSUB lprint(naam$(nummer%)+", "+voor$(nummer%)+" "+geb$(nummer%))
GOSUB lprint("is uit bestand verwijderd.")
GOSUB lprint(" ")
GOSUB lprint("Deze persoon moet verwijderd worden uit:")
ENDIF
ENDIF
PRINT naam$(nummer%);", ";voor$(nummer%);" ";geb$(nummer%)
PRINT "is uit bestand verwijderd."
PRINT
PRINT "Deze persoon moet verwijderd worden uit:"
naam$(nummer%)=""
voor$(nummer%)=""
geb$=""
volg&(nummer%)=0
FOR n&=1 TO maxrel
index&(nummer%,n&,1)=0
index&(nummer%,n&,2)=0
NEXT n&
FOR n&=1 TO trpo
IF trouw&(n&,1)=volg OR trouw&(n&,2)=volg THEN
FOR b&=n& TO trpo-1
trouw&(b&,1)=trouw&(b&+1,1)
trouw&(b&,2)=trouw&(b&+1,2)
trouw$(b&)=trouw$(b&+1)
NEXT b&
DEC trpo
ENDIF
NEXT n&
GOSUB delete_trouw
FOR n&=1 TO last&
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=volg
NEXT b&
IF b&<maxrel THEN
IF ant=1 THEN
IF printboolean! THEN
GOSUB lprint(naam$(n&)+", "+voor$(n&)+" "+geb$(n&))
ENDIF
ENDIF
PRINT naam$(n&);", ";voor$(n&);" ";geb$(n&)
FOR v&=b&+1 TO maxrel
index&(n&,v&-1,1)=index&(n&,v&,1)
index&(n&,v&-1,2)=index&(n&,v&,2)
NEXT v&
index&(n&,maxrel,1)=0
index&(n&,maxrel,2)=0
ENDIF
NEXT n&
PAUSE 100
RETURN
> PROCEDURE delete2(nummer%)
LOCAL n&,b&,v&,volg
IF naam$(nummer%)<>"" THEN
IF ant=1 THEN
IF printboolean! THEN
GOSUB lprint(naam$(nummer%)+", "+voor$(nummer%)+" "+geb$(nummer%))
ENDIF
ENDIF
PRINT naam$(nummer%);", ";voor$(nummer%);" ";geb$(nummer%)
naam$(nummer%)=""
voor$(nummer%)=""
geb$=""
volg=volg&(nummer%)
volg&(nummer%)=0
FOR n&=1 TO trpo
IF trouw&(n&,1)=volg OR trouw&(n&,2)=volg THEN
FOR b&=n& TO trpo-1
trouw&(b&,1)=trouw&(b&+1,1)
trouw&(b&,2)=trouw&(b&+1,2)
trouw$(b&)=trouw$(b&+1)
NEXT b&
DEC trpo
ENDIF
NEXT n&
GOSUB delete_trouw
FOR n&=1 TO maxrel
IF index&(nummer%,n&,2)<>0 THEN
GOSUB volg_nummer(index&(nummer%,n&,1))
GOSUB delete2(volg_nummer%)
ENDIF
NEXT n&
FOR n&=1 TO maxrel
index&(nummer%,n&,1)=0
index&(nummer%,n&,2)=0
NEXT n&
FOR n&=1 TO last&
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=volg
NEXT b&
IF b&<maxrel THEN
GOSUB delete2(n&)
ENDIF
NEXT n&
ENDIF
RETURN
> PROCEDURE delete_trouw
LOCAL n&,b&
FOR n&=1 TO trpo
IF trouw&(n&,1)=volg THEN
FOR b&=n& TO trpo-1
trouw&(b&,1)=trouw&(b&+1,1)
trouw&(b&,2)=trouw&(b&+1,2)
trouw$(b&)=trouw$(b&+1)
NEXT b&
DEC trpo
ENDIF
NEXT n&
RETURN
> PROCEDURE see
MENU KILL
CLS
DO
GOSUB pick(" Kies een persoon uit ! ",sort$)
IF nummer%<>0 THEN
GOSUB vul_invoer
GOSUB laatzien
GOSUB kies("Wilt U dit printen ?")
IF ant=1 THEN
GOSUB print_laatzien
ENDIF
CLS
ENDIF
EXIT IF nummer%=0
LOOP
RETURN
> PROCEDURE plaatje
IF screen$<>"" THEN
MENU KILL
CLS
SPUT screen$
REPEAT
UNTIL MOUSEK<>0 OR INKEY$<>""
CLS
ELSE
ALERT 3," | Nog geen diagram gemaakt. ",1," O.K. ",ant
ENDIF
RETURN
> PROCEDURE vul_invoer
volg=volg&(nummer%)
innaam$=naam$(nummer%)
invoor$=voor$(nummer%)
inges$=ges$(nummer%)
ingeb$=geb$(nummer%)
inov$=ov$(nummer%)
inberoep$=beroep$(nummer%)
inplaats$=plaats$(nummer%)
inop$=op$(nummer%)
FOR b=1 TO maxrel
inindex&(b,1)=index&(nummer%,b,1)
inindex&(b,2)=index&(nummer%,b,2)
NEXT b
RETURN
> PROCEDURE dia1
MENU KILL
CLS
GOSUB laatste
GOSUB pick(" Vanuit wie moet een stamboom worden berekend?",sort$)
REPEAT
UNTIL MOUSEK=0
IF nummer%<>0 THEN
CLS
DO
persoon=nummer%
bpo=1
CLS
HIDEM
IF nummer%<>0 THEN
DEFTEXT ,,,4
GOSUB zoek_relatie(nummer%)
pr$="Stamboom van "+voor$(nummer%)+" "+naam$(nummer%)+" geboren: "+geb$(nummer%)
TEXT 320-LEN(pr$)*3,res&*6,pr$
BOX 0,0,639,res&*8
relatie=ant
IF ges$(nummer%)="M" THEN
hoofd!=TRUE
GOSUB boom(1,persoon,160,160)
IF relatie<>0 THEN
hoofd!=FALSE
GOSUB boom(1,relatie,480,480)
FOR n&=1 TO trpo
EXIT IF trouw&(n&,1)=volg&(persoon) AND trouw&(n&,2)=volg&(relatie)
NEXT n&
IF trouw&(n&,1)=volg&(persoon) AND trouw&(n&,2)=volg&(relatie) AND trouw! THEN
TEXT 290,res&*141,trouw$(n&)
ENDIF
ENDIF
ELSE
IF relatie<>0 THEN
hoofd!=FALSE
GOSUB boom(1,relatie,160,160)
FOR n&=1 TO trpo
EXIT IF trouw&(n&,2)=volg&(persoon) AND trouw&(n&,1)=volg&(relatie)
NEXT n&
IF trouw&(n&,2)=volg&(persoon) AND trouw&(n&,1)=volg&(relatie) AND trouw! THEN
TEXT 290,res&*141,trouw$(n&)
ENDIF
ENDIF
hoofd!=TRUE
GOSUB boom(1,persoon,480,480)
ENDIF
'
kinpo=1
GOSUB zoek_moeder(persoon)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,persoon)
ENDIF
GOSUB zoek_vader(persoon)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,persoon)
ENDIF
IF ges$(persoon)="M" THEN
hoofd=5
ELSE
hoofd=484
ENDIF
GOSUB print_broers.zusters
'
IF relatie<>0 THEN
kinpo=1
GOSUB zoek_moeder(relatie)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,relatie)
ENDIF
GOSUB zoek_vader(relatie)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,relatie)
ENDIF
IF ges$(persoon)="V" THEN
hoofd=5
ELSE
hoofd=484
ENDIF
GOSUB print_broers.zusters
ENDIF
'
kinpo=1
GOSUB zoek_kinderen(persoon,persoon)
IF kinpo<>1 OR relatie<>0 THEN
LINE 160,res&*142,480,res&*142
ENDIF
IF kinpo>1 THEN
FOR n=1 TO kinpo-1
relc&(n)=rel&(n)
NEXT n
kinpo=1
ARRAYFILL rel&(),0
GOSUB zoek_kinderen(relatie,persoon)
IF res&=1 THEN
prpo=152
ELSE
prpo=296
ENDIF
FOR b=1 TO n-1
FOR m=1 TO kinpo-1
IF relc&(b)=rel&(m) THEN
LINE 320,res&*142,320,res&*145
pr$=LEFT$(voor$(relc&(b))+" "+naam$(relc&(b))+SPACE$(33),33)+geb$(relc&(b))+" "+ges$(relc&(b))
TEXT 187,prpo,pr$
GOSUB box(184,(prpo+2)/res&,457,(prpo-6)/res&,relc&(b))
ADD prpo,8
ENDIF
NEXT m
NEXT b
ADD prpo,4
FOR b=1 TO n-1
FOR m=1 TO kinpo-1
EXIT IF relc&(b)=rel&(m)
NEXT m
IF m>=kinpo THEN
pr$=LEFT$(voor$(relc&(b))+" "+naam$(relc&(b))+SPACE$(33),33)+geb$(relc&(b))+" "+ges$(relc&(b))
TEXT 187,prpo,pr$
GOSUB box(184,(prpo+2)/res&,457,(prpo-6)/res&,relc&(b))
IF ges$(persoon)="M" THEN
LINE 184,prpo-2,174,prpo-2
LINE 174,prpo-2,174,142*res&
ELSE
LINE 457,prpo-2,467,prpo-2
LINE 467,prpo-2,467,res&*142
ENDIF
ADD prpo,8
ENDIF
NEXT b
ENDIF
ENDIF
SHOWM
PRINT CHR$(7);
SGET screen$
REPEAT
uit=0
REPEAT
MOUSE x,y,k
UNTIL k<>0
IF k=2 THEN
uit=2
ENDIF
IF k=1 THEN
FOR n=1 TO bpo-1
IF x>bc&(n,1) AND x<bc&(n,3) AND y<bc&(n,2) AND y>bc&(n,4) THEN
uit=1
nummer%=bc&(n,5)
b=n
ENDIF
NEXT n
ENDIF
IF uit=1 THEN
GRAPHMODE 3
PBOX bc&(b,1),bc&(b,2),bc&(b,3),bc&(b,4)
GRAPHMODE 1
REPEAT
UNTIL MOUSEK=0
CLS
GOSUB vul_invoer
GOSUB laatzien
GOSUB kies("Wilt U van dit persoon een stamboom?")
IF ant=2 THEN
uit=0
CLS
SPUT screen$
ENDIF
ENDIF
UNTIL uit<>0
EXIT IF uit=2
LOOP
ENDIF
CLS
DEFTEXT ,,,6
RETURN
> PROCEDURE print_broers.zusters
FOR n=1 TO kinpo-1
EXIT IF kinpo=1
IF hoofd=5 THEN
LINE 80,res&*145,80,res&*140
LINE 80,res&*140,2,res&*140
IF trouw! THEN
LINE 2,res&*140,2,res&*120
LINE 2,res&*120,160,res&*120
ELSE
LINE 2,res&*140,2,res&*118
LINE 2,res&*118,160,res&*118
ENDIF
ELSE
LINE 560,res&*145,560,res&*140
LINE 560,res&*140,637,res&*140
IF trouw! THEN
LINE 637,res&*140,637,res&*120
LINE 637,res&*120,480,res&*120
ELSE
LINE 637,res&*140,637,res&*118
LINE 637,res&*118,480,res&*118
ENDIF
ENDIF
pr$=LEFT$(voor$(rel&(n))+SPACE$(12),12)+" "+geb$(rel&(n))+" "+ges$(rel&(n))
TEXT hoofd,res&*144+8*n,pr$
IF res&=1 THEN
GOSUB box(hoofd-2,146+8*n,hoofd+154,138+8*n,rel&(n))
ELSE
GOSUB box(hoofd-2,72+(146+8*n)/res&,hoofd+154,72+(138+8*n)/res&,rel&(n))
ENDIF
NEXT n
RETURN
> PROCEDURE boom(gener,per,mid,midoud)
LOCAL spli,vader%,moeder%
IF gener=1 THEN
spli=80
maxlen=48
ENDIF
IF gener=2 THEN
spli=40
maxlen=25
ENDIF
IF gener=3 THEN
spli=20
maxlen=11
ENDIF
IF gener=4 THEN
spli=10
maxlen=11
ENDIF
IF gener=5 THEN
maxlen=5*res&
ENDIF
hoofd=0
IF hoofd! AND mid>=320 THEN
hoofd=320
ENDIF
'
pr$=voor$(per)+" "+naam$(per)
geb$=geb$(per)
IF LEN(pr$)>maxlen THEN
IF voor! THEN
pr$=LEFT$(voor$(per),1)+"."+naam$(per)
ELSE
pr$=naam$(per)
ENDIF
ENDIF
IF opt=1 THEN
IF LEN(pr$)<11 THEN
pr$=pr$+" "
ENDIF
ENDIF
pr$=LEFT$(pr$,maxlen)
'
IF gener<=3 THEN
IF opt=2 THEN
TEXT mid-((6*LEN(pr$))/2),res&*(149-20*gener)+1,pr$
ELSE
IF res&=2 THEN
TEXT mid-((6*LEN(pr$))/2),res&*(149-20*gener)-4,pr$
ELSE
TEXT mid-((6*LEN(pr$))/2),res&*(149-20*gener)-2,pr$
ENDIF
TEXT mid-((6*LEN(pr$))/2),res&*(149-20*gener)+4,geb$
ENDIF
GOSUB box(mid-((6*LEN(pr$))/2)-3,154-20*gener,mid+((6*LEN(pr$))/2)+2,142-20*gener,per)
IF trouw! THEN
LINE midoud,res&*(142-20*(gener-1)),midoud,res&*(140-20*(gener-1))
LINE midoud,res&*(140-20*(gener-1)),mid,res&*(160-20*gener)
LINE mid,res&*(154-20*gener),mid,res&*(160-20*gener)
ELSE
LINE midoud,res&*(142-20*(gener-1)),midoud,res&*(138-20*(gener-1))
LINE midoud,res&*(138-20*(gener-1)),mid,res&*(158-20*gener)
LINE mid,res&*(154-20*gener),mid,res&*(158-20*gener)
ENDIF
ENDIF
IF gener=4 THEN
IF opt=2 THEN
TEXT 2*(mid-hoofd)-6*LEN(pr$)/2,res&*(139-20*gener)+1,pr$
ELSE
IF res&=2 THEN
TEXT 2*(mid-hoofd)-6*LEN(pr$)/2,res&*(139-20*gener)-4,pr$
ELSE
TEXT 2*(mid-hoofd)-6*LEN(pr$)/2,res&*(139-20*gener)-2,pr$
ENDIF
TEXT 2*(mid-hoofd)-6*LEN(pr$)/2,res&*(139-20*gener)+4,geb$
ENDIF
GOSUB box(2*(mid-3-hoofd)-6*LEN(pr$)/2,144-20*gener,2*(mid+2-hoofd)+6*LEN(pr$)/2,132-20*gener,per)
IF ges$(persoon)="M" THEN
LINE midoud,res&*(142-20*(gener-1)),midoud,res&*(124+(midoud-hoofd)/20-20*(gener-1))
LINE 2*(mid-hoofd),res&*(144-20*gener),2*(mid-hoofd),res&*(144-20*gener+(midoud-hoofd)/20)
LINE midoud,res&*(124+(midoud-hoofd)/20-20*(gener-1)),2*(mid-hoofd),res&*(144-20*gener+(midoud-hoofd)/20)
ELSE
LINE midoud,res&*(142-20*(gener-1)),midoud,res&*(140-(midoud-hoofd)/20-20*(gener-1))
LINE 2*(mid-hoofd),res&*(144-20*gener),2*(mid-hoofd),res&*(160-20*gener-(midoud-hoofd)/20)
LINE midoud,res&*(140-(midoud-hoofd)/20-20*(gener-1)),2*(mid-hoofd),res&*(160-20*gener-(midoud-hoofd)/20)
ENDIF
ENDIF
IF gener=5 THEN
DEFTEXT ,,900
TEXT 2*(mid-hoofd)-1,res&*(139-20*gener),pr$
GOSUB box(2*(mid-hoofd)-10,143-20*gener,2*(mid-hoofd)+5,9,per)
DEFTEXT ,,0
LINE 2*(midoud-hoofd),res&*(152-20*(gener)),2*(midoud-hoofd),res&*(148-20*(gener))
LINE 2*(mid-hoofd),res&*(143-20*gener),2*(mid-hoofd),res&*(148-20*gener)
LINE 2*(midoud-hoofd),res&*(148-20*(gener)),2*(mid-hoofd),res&*(148-20*gener)
ENDIF
'
IF gener<3 OR (hoofd!=TRUE AND gener<=4) THEN
CLR vader%,moeder%
GOSUB zoek_vader(per)
IF ant<>0 THEN
vader%=ant
GOSUB boom(gener+1,ant,mid-spli,mid)
ENDIF
GOSUB zoek_moeder(per)
IF ant<>0 THEN
moeder%=ant
GOSUB boom(gener+1,ant,mid+spli,mid)
ENDIF
IF vader%<>0 AND moeder%<>0 AND trouw! THEN
FOR bm&=1 TO trpo
IF volg&(vader%)=trouw&(bm&,1) AND volg&(moeder%)=trouw&(bm&,2) AND gener<3 THEN
TEXT mid-30,res&*(141-20*gener)-4,trouw$(bm&)
ENDIF
NEXT bm&
ENDIF
ENDIF
RETURN
> PROCEDURE box(x,y,x1,y1,id)
BOX x,res&*y,x1,res&*y1
bc&(bpo,1)=x
bc&(bpo,2)=res&*y
bc&(bpo,3)=x1
bc&(bpo,4)=res&*y1
bc&(bpo,5)=id
INC bpo
RETURN
> PROCEDURE zoek_relatie(i&)
ant=0
ARRAYFILL rel&(),0
relpo=1
FOR b&=1 TO maxrel
IF index&(i&,b&,2)=3 THEN
GOSUB volg_nummer(index&(i&,b&,1))
FOR c%=1 TO relpo
EXIT IF rel&(c%)=volg_nummer%
NEXT c%
IF c%>relpo THEN
rel&(relpo)=volg_nummer%
INC relpo
ENDIF
ENDIF
NEXT b&
FOR n&=1 TO last&
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=0
IF index&(n&,b&,1)=volg&(i&) AND index&(n&,b&,2)=3 THEN
FOR c%=1 TO relpo
EXIT IF rel&(c%)=n&
NEXT c%
IF c%>relpo THEN
rel&(relpo)=n&
INC relpo
ENDIF
ENDIF
NEXT b&
NEXT n&
IF relpo>1 THEN
IF relpo=2 THEN
ant=rel&(1)
ELSE
IF staat!=FALSE
num=1
DO
CLS
~FORM_CENTER(dia4%,x&,y&,w&,h&)
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
DO
CHAR{{OB_SPEC(dia4%,persoon&)}}=voor$(i&)+" "+naam$(i&)
CHAR{{OB_SPEC(dia4%,relatie&)}}=voor$(rel&(num))+" "+naam$(rel&(num))
~OBJC_DRAW(dia4%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia4%,0)
IF a%=links&
OB_STATE(dia4%,links&)=BCLR(OB_STATE(dia4%,links&),0)
DEC num
ENDIF
IF a%=rechts&
OB_STATE(dia4%,rechts&)=BCLR(OB_STATE(dia4%,rechts&),0)
INC num
ENDIF
num=MIN(relpo-1,MAX(1,num))
EXIT IF a%=keuze&
LOOP
SHOWM
IF a%=keuze& THEN
OB_STATE(dia4%,keuze&)=BCLR(OB_STATE(dia4%,keuze&),0)
ENDIF
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
kies$=CHR$(4)+"| "+LEFT$(naam$(rel&(num)),10)+" |"+CHR$(3)
EXIT IF a%=keuze&
LOOP
CLS
ant=rel&(num)
ELSE
ant=relpo-1
ENDIF
ENDIF
ENDIF
RETURN
> PROCEDURE zoek_vader(i&)
ant=0
FOR b&=1 TO maxrel
IF index&(i&,b&,2)=2 THEN
GOSUB volg_nummer(index&(i&,b&,1))
ENDIF
EXIT IF index&(i&,b&,2)=2 AND ges$(volg_nummer%)="M"
NEXT b&
IF b&<=maxrel THEN
GOSUB volg_nummer(index&(i&,b&,1))
ant=volg_nummer%
ELSE
FOR n&=1 TO last&
IF ges$(n&)="M" THEN
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=0
IF index&(n&,b&,1)=volg&(i&) AND index&(n&,b&,2)=1 THEN
ant=n&
ENDIF
NEXT b&
ENDIF
EXIT IF ant=n&
NEXT n&
ENDIF
RETURN
> PROCEDURE zoek_moeder(i&)
ant=0
FOR b&=1 TO maxrel
IF index&(i&,b&,2)=2 THEN
GOSUB volg_nummer(index&(i&,b&,1))
ENDIF
EXIT IF index&(i&,b&,2)=2 AND ges$(volg_nummer%)="V"
NEXT b&
IF b&<=maxrel THEN
GOSUB volg_nummer(index&(i&,b&,1))
ant=volg_nummer%
ELSE
FOR n&=1 TO last&
IF ges$(n&)="V" THEN
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=0
IF index&(n&,b&,1)=volg&(i&) AND index&(n&,b&,2)=1 THEN
ant=n&
ENDIF
NEXT b&
ENDIF
EXIT IF ant=n&
NEXT n&
ENDIF
RETURN
> PROCEDURE zoek_kinderen(i&,exclude)
ant=0
FOR b&=1 TO maxrel
IF index&(i&,b&,2)=1 THEN
GOSUB volg_nummer(index&(i&,b&,1))
IF volg_nummer%<>exclude THEN
FOR c&=1 TO kinpo
EXIT IF rel&(c&)=volg_nummer%
NEXT c&
IF c&>kinpo THEN
rel&(kinpo)=volg_nummer%
INC kinpo
ENDIF
ENDIF
ENDIF
NEXT b&
FOR n&=1 TO last&
FOR b&=1 TO maxrel
EXIT IF index&(n&,b&,1)=0
IF index&(n&,b&,1)=volg&(i&) AND index&(n&,b&,2)=2 THEN
IF n&<>exclude THEN
FOR c&=1 TO kinpo
EXIT IF rel&(c&)=n&
NEXT c&
IF c&>kinpo THEN
rel&(kinpo)=n&
INC kinpo
ENDIF
ENDIF
ENDIF
NEXT b&
NEXT n&
RETURN
> PROCEDURE volg_nummer(invoer)
FOR v&=1 TO last&
EXIT IF volg&(v&)=invoer
NEXT v&
volg_nummer%=v&
RETURN
> PROCEDURE sorteer
IF sort!=FALSE THEN
GOSUB laatste
GOSUB sorteerst
sort!=TRUE
IF last&=1
ant$=STR$(last&)+" naam"
ELSE
ant$=STR$(last&)+" namen"
ENDIF
sort$=" Bestand is gesorteerd! "+ant$+" in file. "
GOSUB open_bar("De stamboom wordt gesorteerd")
FOR n&=slast& TO last&-1
ex!=FALSE
FOR b&=n& DOWNTO 1
IF naam$(b&)+RIGHT$(geb$(b&),4)>naam$(b&+1)+RIGHT$(geb$(b&+1),4)
SWAP volg&(b&),volg&(b&+1)
SWAP naam$(b&),naam$(b&+1)
SWAP voor$(b&),voor$(b&+1)
SWAP ges$(b&),ges$(b&+1)
SWAP geb$(b&),geb$(b&+1)
SWAP ov$(b&),ov$(b&+1)
SWAP beroep$(b&),beroep$(b&+1)
SWAP plaats$(b&),plaats$(b&+1)
SWAP op$(b&),op$(b&+1)
FOR v&=1 TO maxrel
EXIT IF index&(b&,v&,2)+index&(b&+1,v&,2)=0
SWAP index&(b&,v&,1),index&(b&+1,v&,1)
SWAP index&(b&,v&,2),index&(b&+1,v&,2)
NEXT v&
FOR v&=v& TO maxrel
index&(b&,v&,1)=0
index&(b&,v&,2)=0
index&(b&+1,v&,1)=0
index&(b&+1,v&,2)=0
NEXT v&
ELSE
ex!=TRUE
ENDIF
EXIT IF ex!
NEXT b&
GOSUB bar(last&-slast&,n&-slast&)
NEXT n&
GOSUB close_bar
ENDIF
FOR n&=last& DOWNTO 1
EXIT IF naam$(n&)<>"~"
DEC last&
naam$(n&)=""
NEXT n&
PRINT CHR$(7);
RETURN
> PROCEDURE sorteerst
slast&=1
FOR n&=1 TO last&-1
EXIT IF naam$(n&)+RIGHT$(geb$(n&),4)>naam$(n&+1)+RIGHT$(geb$(n&+1),4) OR naam$=""
NEXT n&
slast&=MAX(1,n&-1)
FOR n&=1 TO last&
IF naam$(n&)="" THEN
naam$(n&)="~"
ENDIF
NEXT n&
RETURN
> PROCEDURE copy
MENU KILL
HIDEM
CLS
IF screen$="" THEN
ALERT 3," | Nog geen diagram gemaakt. ",1," O.K. ",ant
ELSE
GOSUB printer
IF printboolean! THEN
SPUT screen$
GOSUB hardcopy
IF GEMDOS(17)=TRUE THEN
LPRINT "@";
IF formfeed! THEN
GOSUB lprint("")
ENDIF
ENDIF
ENDIF
ENDIF
SHOWM
LET printboolean!=FALSE
CLS
RETURN
> PROCEDURE stats
GOSUB laatste
REPEAT
dfr=DFREE(ASC(dr$)-64)
IF last&=1
ant$=STR$(last&)+" naam"
ELSE
ant$=STR$(last&)+" namen"
ENDIF
IF last&=1 THEN
ant$="is "+ant$
ELSE
ant$="zijn "+ant$
ENDIF
ALERT 1," Er "+ant$+" | "+STR$(INT(FRE()/1024))+" Kbyte RAM vrij| "+STR$(INT(dfr/1024))+" Kbyte DISK vrij| Maximaal "+STR$(max)+" records",2," "+CHR$(4)+" | "+dr$+" | "+CHR$(3)+" ",ant
dri&=ASC(dr$)-65
IF ant=1 THEN
REPEAT
DEC dri&
UNTIL dri&=-1 OR 2^dri& AND BIOS(10)
IF dri&=-1 THEN
dri&=31
REPEAT
DEC dri&
UNTIL dri&=0 OR 2^dri& AND BIOS(10)
ENDIF
dr$=CHR$(dri&+65)
ENDIF
IF ant=3 THEN
REPEAT
INC dri&
UNTIL dri&=30 OR 2^dri& AND BIOS(10)
IF dri&=30 THEN
dri&=-1
REPEAT
INC dri&
UNTIL dri&=30 OR 2^dri& AND BIOS(10)
ENDIF
dr$=CHR$(dri&+65)
ENDIF
UNTIL ant=2
RETURN
> PROCEDURE init
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
RESERVE -6000
LET dialog&=0 !RSC_TREE
LET info&=2 !Obj in #0
LET achter&=4 !Obj in #0
LET voor&=5 !Obj in #0
LET geslacht&=6 !Obj in #0
LET beroep&=7 !Obj in #0
LET gjaar&=11 !Obj in #0
LET gmaand&=12 !Obj in #0
LET gdag&=13 !Obj in #0
LET ojaar&=15 !Obj in #0
LET omaand&=16 !Obj in #0
LET odag&=17 !Obj in #0
LET plaats&=18 !Obj in #0
LET cancel&=20 !Obj in #0
LET ok&=21 !Obj in #0
LET trouw&=1 !RSC_TREE
LET man&=2 !Obj in #1
LET vrouw&=4 !Obj in #1
LET rjaar&=6 !Obj in #1
LET rmaand&=7 !Obj in #1
LET rdag&=8 !Obj in #1
LET rok&=9 !Obj in #1
LET rcancel&=10 !Obj in #1
LET delete&=2 !RSC_TREE
LET del&=2 !Obj in #2
LET spec&=3 !Obj in #2
LET opm&=22 !Obj in #0
LET alert&=3 !RSC_TREE
LET persoon&=4 !Obj in #3
LET links&=6 !Obj in #3
LET rechts&=7 !Obj in #3
LET relatie&=8 !Obj in #3
LET keuze&=9 !Obj in #3
LET prefer&=4 !RSC_TREE
LET jadat&=7 !Obj in #4
LET needat&=8 !Obj in #4
LET prefok&=37 !Obj in #4
LET save&=38 !Obj in #4
LET jarel&=10 !Obj in #4
LET neerel&=11 !Obj in #4
LET jaextra&=13 !Obj in #4
LET neeextra&=14 !Obj in #4
LET jatro&=19 !Obj in #4
LET neetro&=20 !Obj in #4
LET javoor&=23 !Obj in #4
LET neevoor&=24 !Obj in #4
LET zoek&=5 !RSC_TREE
LET is&=3 !Obj in #5
LET groter&=4 !Obj in #5
LET kleiner&=5 !Obj in #5
LET ongelijk&=6 !Obj in #5
LET zoekstri&=7 !Obj in #5
LET alle&=9 !Obj in #5
LET select&=10 !Obj in #5
LET zoeken&=11 !Obj in #5
LET zcancel&=12 !Obj in #5
LET selinfo&=13 !Obj in #5
LET zinfo&=14 !Obj in #5
LET vlengte&=40 !Obj in #4
LET gener&=41 !Obj in #4
LET datum&=6 !RSC_TREE
LET djaar&=5 !Obj in #6
LET dmaand&=6 !Obj in #6
LET ddag&=7 !Obj in #6
LET datok&=8 !Obj in #6
LET jaleef&=27 !Obj in #4
LET neeleef&=28 !Obj in #4
LET paglen&=42 !Obj in #4
LET perfor&=43 !Obj in #4
LET janlq&=31 !Obj in #4
LET neenlq&=32 !Obj in #4
LET jaform&=34 !Obj in #4
LET neeform&=35 !Obj in #4
dr$=CHR$(65+GEMDOS(&H19))
GOSUB laatste_file
rsc_naam$=path$+"STAMBOOM.RSC"
' CHDIR path$
IF RSRC_LOAD(rsc_naam$)=0 THEN
ALERT 1," | STAMBOOM.RSC niet gevonden.",1,"OK",ant
EDIT
ENDIF
~RSRC_GADDR(0,dialog&,dia1%)
~RSRC_GADDR(0,trouw&,dia2%)
~RSRC_GADDR(0,delete&,dia3%)
~RSRC_GADDR(0,alert&,dia4%)
~RSRC_GADDR(0,prefer&,dia5%)
~RSRC_GADDR(0,zoek&,dia6%)
~RSRC_GADDR(0,datum&,dia7%)
~FORM_CENTER(dia1%,xdia1&,ydia1&,wdia1&,hdia1&)
~FORM_CENTER(dia2%,xdia2&,ydia2&,wdia2&,hdia2&)
IF EXIST("STAMBOOM.INF") THEN
OPEN "i",#1,"STAMBOOM.INF"
INPUT #1;recht!
INPUT #1;naald9!
INPUT #1;maxrel
INPUT #1;opt
INPUT #1;rel!
INPUT #1;extra!
INPUT #1;trouw!
INPUT #1;voor!
INPUT #1;diepte%
INPUT #1;sidelen&
INPUT #1;leef!
INPUT #1;nlq!
INPUT #1;page%
INPUT #1;skip%
INPUT #1;formfeed!
CLOSE #1
ELSE
recht!=TRUE
naald9!=FALSE
maxrel=10
voor!=TRUE
rel!=TRUE
extra!=TRUE
opt=1
trouw!=TRUE
diepte%=10
sidelen&=15
leef!=FALSE
nlq!=FALSE
skip%=0
page%=66
formfeed!=FALSE
ENDIF
DEFTEXT ,,,6
max=INT((FRE()-50000)/280)-50
max=MIN(5000,max)
prmax=18
sort!=FALSE
staat!=FALSE
LET printboolean!=FALSE
begpri=1
ver=1
sel=1
trpo=1
filename$=path$+"*.FAM"
laatste_file$=""
DIM volg&(max),naam$(max),voor$(max),ges$(max)
DIM geb$(max),ov$(max),index&(max,maxrel,2),op$(max)
DIM plaats$(max),beroep$(max)
DIM inindex&(maxrel,2),prindex&(prmax),rel&(50),relc&(50),bc&(100,5)
DIM sel1&(max),sel2&(2*max)
DIM trouw&(max/2,2),trouw$(max/2)
RETURN
> PROCEDURE make_menu
RESTORE m_data
DIM menu1$(70)
FOR i=0 TO 70
READ menu1$(i)
EXIT IF menu1$(i)="****"
NEXT i
LET menu1$(i)=""
LET menu1$(i+1)=""
m_data:
DATA Desk ," Info "
DATA -------------------------
DATA 1,2,3,4,5,6,""
DATA File , New N ,-------------, Load L , Merge M , Save S , Save pic P ,-------------, Quit Q ,""
DATA Options , Voeg toe A , Verwijder D , Verander C , Vervang , Trouwdata T,---------------, Zoek op Z , Voorkeur V , Plaatje ,""
DATA Extra , Diagram 1 1 , Diagram 2 2 , Diagram 3 3 , Familiestaat 4 ,-----------------, Sorteer O , Hardcopy H , Statistiek ,""
DATA Zoek , Naam , Voornaam , Geslacht , Geboren , Overleden , Beroep , Plaats , Opmerking , Leeftijd ,----------------, Kinderen , Broers/Zusters , 'Motjes' ,""
DATA Uitvoer , Geselecteerd: ,---------------------, List , Llist , Llist records ,---------------------, Invert I, Reset R,""
DATA ****
RETURN
> PROCEDURE laatste
last&=0
FOR n&=1 TO max
IF naam$(n&)<>"" THEN
last&=n&
ENDIF
NEXT n&
RETURN
> PROCEDURE maakvolg
GOSUB laatste
volg=0
FOR n=1 TO last&
volg=MAX(volg&(n),volg)
NEXT n
INC volg
RETURN
> PROCEDURE kies(pr$)
DEFFILL 1,2,4
PRBOX 40,res&*165,600,res&*198
DEFFILL 1,0
PBOX 240,res&*180,310,res&*195
PBOX 330,res&*180,400,res&*195
DEFFILL 1,1
PRINT AT(41-(LEN(pr$)/2),22);pr$
PRINT AT(33,24);" Ja ";AT(45,24);"Nee"
BOX 240,res&*180,310,res&*195
BOX 239,res&*179,311,res&*196
BOX 330,res&*180,400,res&*195
ant=0
REPEAT
MOUSE x,y,k
IF k=1 AND y>res&*180 AND y<res&*195 THEN
IF x>240 AND x<310 THEN
ant=1
ENDIF
IF x>330 AND x<400 THEN
ant=2
ENDIF
ENDIF
k$=UPPER$(INKEY$)
IF ASC(k$)=13 OR k$="J" OR k$="Y" THEN
ant=1
ENDIF
IF k$="N" THEN
ant=2
ENDIF
IF k=2 THEN
ant=2
ENDIF
UNTIL ant=1 OR ant=2
GRAPHMODE 3
IF ant=1 THEN
PBOX 240,res&*180,310,res&*195
ELSE
PBOX 330,res&*180,400,res&*195
ENDIF
GRAPHMODE 1
REPEAT
UNTIL MOUSEK=0
RETURN
> PROCEDURE fout
MENU KILL
CLS
fout$=" | Er is een fout opgetreden ! | Foutmelding : "+STR$(ERR)
IF FATAL THEN
fout$=fout$+" | Fout is fataal !"
ELSE
fout$=fout$+" | Fout is niet fataal. "
ENDIF
ALERT 1,fout$,1," O.K. ",ant
COLOR 1
DEFFILL 1,2,4
PBOX -1,-1,641,401
CLOSE #1
CLOSE #2
RESUME foutlabel
RETURN
> PROCEDURE open_box(pr$)
GET 200,11*res&,440,26*res&,box$
DEFFILL ,0,0
PBOX 200,11*res&,440,26*res&
BOX 200,11*res&,440,26*res&
BOX 201,11*res&+1,439,26*res&-1
BOX 203,11*res&+3,437,26*res&-3
DEFFILL ,2,1
TEXT 320-4*LEN(pr$),20*res&,pr$
RETURN
> PROCEDURE close_box
PUT 200,11*res&,box$
DEFFILL 1,1
RETURN
> PROCEDURE open_bar(pr$)
GET 100,60*res&,540,120*res&,bar$
DEFFILL ,0,0
PBOX 100,60*res&,540,120*res&
BOX 100,60*res&,540,120*res&
BOX 101,60*res&+1,539,120*res&-1
BOX 103,60*res&+3,537,120*res&-3
BOX 159,95*res&-1,481,105*res&+1
DEFFILL ,2,1
TEXT 320-4*LEN(pr$),80*res&,pr$
DEFMOUSE 2
RETURN
> PROCEDURE bar(maxwaarde,waarde)
PBOX 160,95*res&,160+320*(waarde/(maxwaarde+0.01)),105*res&
RETURN
> PROCEDURE close_bar
PUT 100,60*res&,bar$
DEFFILL 1,1
DEFMOUSE 0
RETURN
> PROCEDURE sorteer_sel
DEFMOUSE 2
l%=0
FOR n&=1 TO 2*max
IF sel2&(n&)<>0 THEN
l%=n&
ENDIF
NEXT n&
FOR n&=1 TO l%
IF sel2&(n&)<>0 THEN
FOR b&=n&+1 TO l%
IF sel2&(n&)=sel2&(b&) THEN
sel2&(n&)=0
ENDIF
NEXT b&
ENDIF
NEXT n&
IF l%>0 THEN
FOR n&=1 TO l%
FOR b&=n& TO l%
EXIT IF sel2&(b&)<>0
NEXT b&
st%=b&-n&
FOR b&=n& TO l%
sel2&(b&)=sel2&(b&+st%)
NEXT b&
NEXT n&
ENDIF
DEFMOUSE 0
RETURN
> PROCEDURE count_sel
FOR n&=1 TO max
EXIT IF sel2&(n&)=0
NEXT n&
select=n&-1
RETURN
> PROCEDURE do_menu1
CLS
~FORM_CENTER(dia6%,x&,y&,w&,h&)
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
IF ver=1 THEN
OB_STATE(dia6%,is&)=BSET(OB_STATE(dia6%,is&),0)
ELSE
OB_STATE(dia6%,is&)=BCLR(OB_STATE(dia6%,is&),0)
ENDIF
IF ver=2 THEN
OB_STATE(dia6%,groter&)=BSET(OB_STATE(dia6%,groter&),0)
ELSE
OB_STATE(dia6%,groter&)=BCLR(OB_STATE(dia6%,groter&),0)
ENDIF
IF ver=3 THEN
OB_STATE(dia6%,kleiner&)=BSET(OB_STATE(dia6%,kleiner&),0)
ELSE
OB_STATE(dia6%,kleiner&)=BCLR(OB_STATE(dia6%,kleiner&),0)
ENDIF
IF ver=4 THEN
OB_STATE(dia6%,ongelijk&)=BSET(OB_STATE(dia6%,ongelijk&),0)
ELSE
OB_STATE(dia6%,ongelijk&)=BCLR(OB_STATE(dia6%,ongelijk&),0)
ENDIF
IF sel=1 THEN
OB_STATE(dia6%,alle&)=BSET(OB_STATE(dia6%,alle&),0)
ELSE
OB_STATE(dia6%,alle&)=BCLR(OB_STATE(dia6%,alle&),0)
ENDIF
IF sel=2 THEN
OB_STATE(dia6%,select&)=BSET(OB_STATE(dia6%,select&),0)
ELSE
OB_STATE(dia6%,select&)=BCLR(OB_STATE(dia6%,select&),0)
ENDIF
SELECT keuze
CASE 36
ke$="Achternaam"
CASE 37
ke$="Voornaam"
CASE 38
ke$="Geslacht"
CASE 39
ke$="Geboortejaar"
CASE 40
ke$="Jaar van overlijden"
CASE 41
ke$="Beroep"
CASE 42
ke$="Plaats"
CASE 43
ke$="Opmerking"
CASE 44
ke$="Leeftijd"
ENDSELECT
CHAR{{OB_SPEC(dia6%,zoekstri&)}}=""
CHAR{{OB_SPEC(dia6%,selinfo&)}}="Geselecteerd : "+STR$(select)
CHAR{{OB_SPEC(dia6%,zinfo&)}}=ke$
DO
~OBJC_DRAW(dia6%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia6%,0)
SELECT BCLR(a%,15)
CASE zoeken&
OB_STATE(dia6%,zoeken&)=BCLR(OB_STATE(dia6%,zoeken&),0)
CASE zcancel&
OB_STATE(dia6%,zcancel&)=BCLR(OB_STATE(dia6%,zcancel&),0)
ENDSELECT
EXIT IF a%=zoeken& OR a%=zcancel&
LOOP
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
IF BTST(OB_STATE(dia6%,is&),0)
ver=1
ENDIF
IF BTST(OB_STATE(dia6%,groter&),0)
ver=2
ENDIF
IF BTST(OB_STATE(dia6%,kleiner&),0)
ver=3
ENDIF
IF BTST(OB_STATE(dia6%,ongelijk&),0)
ver=4
ENDIF
IF BTST(OB_STATE(dia6%,alle&),0)
sel=1
ELSE
sel=2
ENDIF
IF a%=zcancel& THEN
zoek$="cancel"
ELSE
zoek$=UPPER$(CHAR{{OB_SPEC(dia6%,zoekstri&)}})
ENDIF
CLS
RETURN
> PROCEDURE al
MENU KILL
CLS
GOSUB laatste
keuze=keuze-6
GOSUB do_menu1
IF zoek$<>"cancel" THEN
IF keuze<>44 OR (keuze=44 AND VAL(zoek$)<>0) OR (keuze=44 AND zoek$="0") THEN
IF keuze=44 THEN
zoek=VAL(zoek$)
ENDIF
zoek$=UPPER$(zoek$)
IF (keuze=39 OR keuze=40) AND LEN(zoek$)=4 THEN
zoek$=RIGHT$(zoek$,4)
ENDIF
GOSUB open_bar("Ik zoek op "+ke$)
IF sel=1 THEN
FOR n&=1 TO max
sel1&(n&)=volg&(n&)
NEXT n&
eindzoek=last&
selpo&=select+1
ELSE
eindzoek=select
FOR n&=1 TO select
sel1&(n&)=sel2&(n&)
sel2&(n&)=0
NEXT n&
selpo&=1
ENDIF
IF eindzoek=0 THEN
eindzoek=1
ENDIF
FOR n&=1 TO eindzoek
GOSUB volg_nummer(sel1&(n&))
SELECT keuze
CASE 36
ver$=naam$(volg_nummer%)
CASE 37
ver$=voor$(volg_nummer%)
CASE 38
ver$=ges$(volg_nummer%)
CASE 39
ver$=RIGHT$(geb$(volg_nummer%),4)
CASE 40
ver$=RIGHT$(ov$(volg_nummer%),4)
CASE 41
ver$=beroep$(volg_nummer%)
CASE 42
ver$=plaats$(volg_nummer%)
CASE 43
ver$=op$(volg_nummer%)
CASE 44
geb=@leeftijd(geb$(volg_nummer%))
ov=@leeftijd(ov$(volg_nummer%))
tot=(ov-geb)/365.25
ENDSELECT
ver$=UPPER$(ver$)
IF keuze<>44 THEN
IF (ver=1 AND INSTR(ver$,zoek$)<>0) OR (ver=2 AND ver$>=zoek$) OR (ver=3 AND ver$<=zoek$) OR (ver=4 AND INSTR(ver$,zoek$)=0) THEN
sel2&(selpo&)=sel1&(n&)
INC selpo&
ENDIF
ELSE
IF ov<>0 AND geb<>0 AND tot>=0 THEN
IF (ver=1 AND tot=zoek) OR (ver=2 AND tot>=zoek) OR (ver=3 AND tot<=zoek) OR (ver=4 AND tot<>zoek) THEN
sel2&(selpo&)=sel1&(n&)
INC selpo&
ENDIF
ENDIF
ENDIF
GOSUB bar(eindzoek,n&)
NEXT n&
select=selpo&-1
GOSUB close_bar
GOSUB sorteer_sel
GOSUB count_sel
PRINT CHR$(7);
ALERT 3," | Er zijn "+STR$(select)+"| records geselecteerd.",1," O.K. ",ant
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE list
MENU KILL
CLS
bpri=1
DO
LET infow$=sort$
LET title$=" Geselecteerd bestand met "+STR$(select)+" namen."
GOSUB pick_graph
np!=TRUE
index=0
DO
IF np! THEN
GOSUB printlist(bpri)
ENDIF
MOUSE x,y,k
IF k=1 THEN
IF y>res&*16 AND y<res&*28 THEN
bpri=MAX(1,bpri-16)
np!=TRUE
ENDIF
IF y>res&*162 AND y<res&*174 THEN
bpri=MIN(select,bpri+16)
np!=TRUE
ENDIF
IF y>res&*29 AND y<res&*162 THEN
in=(y-(res&*32))/(res&*8)
IF prindex&(in)<>0 THEN
nummer%=prindex&(in)
index=sel2&(nummer%)
GOSUB volg_nummer(index)
index=nummer%
PRINT CHR$(27);"p"
pr$=LEFT$(naam$(nummer%)+", "+voor$(nummer%)+" "+STRING$(65,"-"),65)+" "+geb$(nummer%)+" "+ges$(nummer%)
PRINT AT(2,in+5);pr$
PRINT CHR$(27);"q"
ENDIF
ENDIF
REPEAT
UNTIL MOUSEK=0
ENDIF
EXIT IF index<>0 OR k=2
LOOP
EXIT IF k=2
CLS
GOSUB vul_invoer
GOSUB laatzien
GOSUB kies("Wilt U dit printen?")
IF ant=1 THEN
GOSUB print_laatzien
ENDIF
LOOP
CLS
RETURN
> PROCEDURE printlist(begin)
np!=FALSE
ARRAYFILL prindex&(),0
FOR n&=begin TO begin+15
GOSUB volg_nummer(sel2&(n&))
IF n&<=select THEN
pr$=LEFT$(naam$(volg_nummer%)+", "+voor$(volg_nummer%)+" "+STRING$(65,"-"),65)+" "+geb$(volg_nummer%)+" "+ges$(volg_nummer%)
prindex&(n&-bpri)=volg_nummer%
PRINT AT(2,n&-bpri+5);pr$
ELSE
PRINT AT(2,n&-bpri+5);SPACE$(78)
ENDIF
NEXT n&
RETURN
> PROCEDURE laatzien
HIDEM
CLS
PRINT " ";STRING$(78,"*")
GOSUB lprint(" "+STRING$(78,"*"))
PRINT "Achternaam: ";innaam$
GOSUB lprint("Achternaam: "+innaam$)
PRINT "Voornaam : ";invoor$
GOSUB lprint("Voornaam : "+invoor$)
PRINT "Geslacht : ";inges$
GOSUB lprint("Geslacht : "+inges$)
PRINT "Beroep : ";inberoep$
GOSUB lprint("Beroep : "+inberoep$)
PRINT "Geboren : ";ingeb$;" Overleden : ";inov$
GOSUB lprint("Geboren : "+ingeb$+" Overleden : "+inov$)
geb=@leeftijd(ingeb$)
ov=@leeftijd(inov$)
lft=ov-geb
tot=INT(lft/365.25)
IF MID$(ingeb$,4,2)<>" " AND MID$(inov$,4,2)<>" " AND LEFT$(ingeb$,2)<>" " AND LEFT$(inov$,2)<>" " THEN
dtot=INT(lft-365.25*tot)
dtot$="en "+STR$(dtot)+" dagen"
ELSE
dtot$="(ongeveer)"
ENDIF
IF geb<>0 AND ov<>0 THEN
PRINT "Leeftijd : "+STR$(tot)+" jaar "+dtot$
GOSUB lprint("Leeftijd : "+STR$(tot)+" jaar "+dtot$)
ELSE
PRINT "Geen leeftijd bekend."
GOSUB lprint("Geen leeftijd bekend.")
ENDIF
PRINT "Plaats : ";inplaats$
GOSUB lprint("Plaats : "+inplaats$)
IF trouw! THEN
FOR mb&=1 TO trpo
IF trouw&(mb&,1)=volg OR trouw&(mb&,2)=volg THEN
IF inges$="M" THEN
GOSUB volg_nummer(trouw&(mb&,2))
ELSE
GOSUB volg_nummer(trouw&(mb&,1))
ENDIF
PRINT "Getrouwd met ";voor$(volg_nummer%)+" "+naam$(volg_nummer%)+" op "+trouw$(mb&)
GOSUB lprint("Getrouwd met "+voor$(volg_nummer%)+" "+naam$(volg_nummer%)+" op "+trouw$(mb&))
ENDIF
NEXT mb&
ENDIF
IF inop$<>"" THEN
PRINT inop$
GOSUB lprint(inop$)
ENDIF
GOSUB laatste
IF rel! THEN
PRINT
GOSUB lprint(" ")
FOR n=1 TO maxrel
EXIT IF inindex&(n,1)=0
FOR b=1 TO last&
IF volg&(b)=inindex&(n,1) THEN
CLR prout$
IF inindex&(n,2)=1 THEN
IF inges$="M" THEN
prout$="Vader van "
ELSE
prout$="Moeder van "
ENDIF
ENDIF
IF inindex&(n,2)=2 THEN
IF inges$="M" THEN
prout$="Zoon van "
ELSE
prout$="Dochter van "
ENDIF
ENDIF
IF inindex&(n,2)=3 THEN
IF inges$="M" THEN
prout$="Echtgenoot van "
ELSE
prout$="Echtgenote van "
ENDIF
ENDIF
prout$=prout$+naam$(b)+", "+voor$(b)+" "+geb$(b)
PRINT prout$
GOSUB lprint(prout$)
ENDIF
NEXT b
NEXT n
ENDIF
IF extra! THEN
PRINT
GOSUB lprint(" ")
FOR mb&=1 TO last&
FOR mv&=1 TO maxrel
EXIT IF index&(mb&,mv&,2)=0
IF index&(mb&,mv&,1)=volg THEN
CLR prout$
IF index&(mb&,mv&,2)=2 THEN
IF inges$="M" THEN
prout$="Vader van "
ELSE
prout$="Moeder van "
ENDIF
ENDIF
IF index&(mb&,mv&,2)=1 THEN
IF inges$="M" THEN
prout$="Zoon van "
ELSE
prout$="Dochter van "
ENDIF
ENDIF
IF index&(mb&,mv&,2)=3 THEN
IF inges$="M" THEN
prout$="Echtgenoot van "
ELSE
prout$="Echtgenote van "
ENDIF
ENDIF
prout$=prout$+naam$(mb&)+", "+voor$(mb&)+" "+geb$(mb&)
PRINT prout$
GOSUB lprint(prout$)
ENDIF
NEXT mv&
NEXT mb&
ENDIF
PRINT " ";STRING$(78,"*")
GOSUB lprint(" "+STRING$(78,"*"))
SHOWM
LET printboolean!=FALSE
RETURN
> PROCEDURE print_laatzien
GOSUB printer
ant=1
IF printboolean!=FALSE
ant=FORM_ALERT(1,"[1][ | De printer staat niet online ! ][ Doorgaan | Afbreken ]")
GOSUB printer
ENDIF
IF ant=1 THEN
GOSUB laatzien
ENDIF
PRINT!=false
RETURN
> PROCEDURE lprint(pr$)
IF printboolean! THEN
IF GEMDOS(17)=FALSE THEN
PAUSE 100
ENDIF
IF GEMDOS(17)=TRUE
IF nlq! THEN
LPRINT "x"+CHR$(1);pr$
ELSE
LPRINT "x";CHR$(0);pr$
ENDIF
ELSE
ALERT 2," | De printer staat niet aan ",1," Print | Cancel ",ant
IF ant=2 THEN
LET printboolean!=FALSE
ENDIF
ENDIF
ENDIF
RETURN
> PROCEDURE printer
LET printboolean!=TRUE
IF OUT?(0)=FALSE THEN
LET printboolean!=FALSE
ELSE
LET printboolean!=TRUE
LPRINT "@";
LPRINT "C";CHR$(page%);"N";CHR$(skip%);
ENDIF
RETURN
> PROCEDURE llist
MENU KILL
CLS
ALERT 2," | Print een lijst met | geselecteerde records? ",1," Ja | Nee ",ant
IF ant=1 THEN
GOSUB printer
IF printboolean!=FALSE
ant=FORM_ALERT(1,"[1][ | De printer staat niet online ! ][ Doorgaan | Afbreken ]")
GOSUB printer
ENDIF
IF ant=1 THEN
IF printboolean!=TRUE THEN
FOR n&=1 TO select
GOSUB volg_nummer(sel2&(n&))
pr$=" "+LEFT$(naam$(volg_nummer%)+", "+voor$(volg_nummer%)+" "+STRING$(65,"-"),65)+" "+geb$(volg_nummer%)+" "+ges$(volg_nummer%)
EXIT IF INKEY$<>"" OR MOUSEK=2
PRINT pr$
GOSUB lprint(pr$)
NEXT n&
ENDIF
IF formfeed! THEN
GOSUB lprint("")
ENDIF
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE llrec
MENU KILL
CLS
ALERT 2," | Print geselecteerde | records? ",1," Ja | Nee ",ant
IF ant=1 THEN
GOSUB printer
IF printboolean!=FALSE
ant=FORM_ALERT(1,"[1][ | De printer staat niet online ! ][ Doorgaan | Afbreken ]")
GOSUB printer
ENDIF
IF ant=1 THEN
IF printboolean!=TRUE THEN
FOR nn&=1 TO select
EXIT IF INKEY$<>"" OR MOUSEK=2
GOSUB volg_nummer(sel2&(nn&))
nummer%=volg_nummer%
GOSUB vul_invoer
CLS
GOSUB print_laatzien
NEXT nn&
ENDIF
IF formfeed! THEN
GOSUB lprint("")
ENDIF
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE inv
GOSUB laatste
IF last&>0 THEN
selpo&=1
GOSUB laatste
GOSUB open_bar("Verwissel geselecteerde met niet geselecteerde records")
FOR n&=1 TO last&
FOR b&=1 TO select
EXIT IF volg&(n&)=sel2&(b&)
NEXT b&
IF b&>select THEN
sel1&(selpo&)=volg&(n&)
INC selpo&
ENDIF
GOSUB bar(last&,n&)
NEXT n&
GOSUB close_bar
select=selpo&-1
FOR n&=1 TO select
sel2&(n&)=sel1&(n&)
NEXT n&
FOR n&=select+1 TO max
sel2&(n&)=0
NEXT n&
PRINT CHR$(7);
CLS
ELSE
PRINT CHR$(7);
CLS
ENDIF
RETURN
> PROCEDURE kind
MENU KILL
CLS
GOSUB pick(" Zoek de kinderen van:",sort$)
CLS
IF nummer%<>0 THEN
GOSUB res
kinpo=1
ARRAYFILL rel&(),0
GOSUB zoek_kinderen(nummer%,0)
FOR n=1 TO kinpo-1
sel2&(n)=volg&(rel&(n))
NEXT n
GOSUB sorteer_sel
GOSUB count_sel
ALERT 3," | "+STR$(kinpo-1)+" kinderen | gevonden.",1," O.K. ",ant
ENDIF
RETURN
> PROCEDURE brzs
MENU KILL
CLS
GOSUB pick(" Zoek de broers en zusters van:",sort$)
CLS
IF nummer%<>0 THEN
persoon=nummer%
GOSUB res
kinpo=1
ARRAYFILL rel&(),0
GOSUB zoek_moeder(persoon)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,persoon)
ENDIF
GOSUB zoek_vader(persoon)
IF ant<>0 THEN
GOSUB zoek_kinderen(ant,persoon)
ENDIF
FOR n=1 TO kinpo-1
sel2&(n)=volg&(rel&(n))
NEXT n
GOSUB sorteer_sel
GOSUB count_sel
ALERT 3," | "+STR$(kinpo-1)+" broers en | zusters gevonden.",1," O.K. ",ant
ENDIF
RETURN
> PROCEDURE res
ARRAYFILL sel1&(),0
ARRAYFILL sel2&(),0
FOR n&=1 TO max
sel1&(n&)=volg&(n&)
NEXT n&
GOSUB count_sel
RETURN
> PROCEDURE trouw
MENU KILL
CLS
GOSUB pick(" Wie is er getrouwd :",sort$)
IF nummer%<>0 THEN
t1%=nummer%
REPEAT
GOSUB pick(LEFT$(" "+naam$(t1%)+" "+voor$(t1%)+" "+ges$(t1%)+" "+geb$(t1%),76)," is getrouwd met :")
UNTIL nummer%=0 OR ges$(t1%)<>ges$(nummer%)
IF nummer%<>0 THEN
t2%=nummer%
IF ges$(t1%)="V" THEN
SWAP t1%,t2%
ENDIF
FOR n&=1 TO trpo
EXIT IF trouw&(n&,1)=volg&(t1%) AND trouw&(n&,2)=volg&(t2%)
NEXT n&
'
CHAR{{OB_SPEC(dia2%,man&)}}=naam$(t1%)+" "+voor$(t1%)+" "+geb$(t1%)
CHAR{{OB_SPEC(dia2%,vrouw&)}}=naam$(t2%)+" "+voor$(t2%)+" "+geb$(t2%)
IF trouw&(n&,1)=volg&(t1%) AND trouw&(n&,2)=volg&(t2%) THEN
CHAR{{OB_SPEC(dia2%,rjaar&)}}=RIGHT$(trouw$(n&),4)
CHAR{{OB_SPEC(dia2%,rmaand&)}}=MID$(trouw$(n&),4,2)
CHAR{{OB_SPEC(dia2%,rdag&)}}=LEFT$(trouw$(n&),2)
ELSE
CHAR{{OB_SPEC(dia2%,rjaar&)}}=""
CHAR{{OB_SPEC(dia2%,rmaand&)}}=""
CHAR{{OB_SPEC(dia2%,rdag&)}}=""
ENDIF
' ~FORM_CENTER(dia2%,x&,y&,w&,h&)
' ~FORM_DIAL(0,320,200,20,20,xdia2&,ydia2&,wdia2&,hdia2&)
~FORM_DIAL(1,320,200,20,20,xdia2&,ydia2&,wdia2&,hdia2&)
DO
~OBJC_DRAW(dia2%,0,7,xdia2&,ydia2&,wdia2&,hdia2&)
a%=FORM_DO(dia2%,0)
SELECT BCLR(a%,15)
CASE rok&
rmaand$=CHAR{{OB_SPEC(dia2%,rmaand&)}}
rdag$=CHAR{{OB_SPEC(dia2%,rdag&)}}
IF VAL(rmaand$)>12 OR VAL(rdag$)>31 THEN
PRINT CHR$(7);
a%=0
ENDIF
OB_STATE(dia2%,rok&)=BCLR(OB_STATE(dia2%,rok&),0)
ENDSELECT
EXIT IF a%=rok& OR a%=rcancel&
LOOP
SHOWM
IF a%=rcancel& THEN
OB_STATE(dia2%,rcancel&)=BCLR(OB_STATE(dia2%,rcancel&),0)
ENDIF
~FORM_DIAL(2,320,200,20,20,xdia2&,ydia2&,wdia2&,hdia2&)
~FORM_DIAL(3,320,200,20,20,xdia2&,ydia2&,wdia2&,hdia2&)
IF a%=rok& THEN
rjaar$=CHAR{{OB_SPEC(dia2%,rjaar&)}}
rmaand$=CHAR{{OB_SPEC(dia2%,rmaand&)}}
rdag$=CHAR{{OB_SPEC(dia2%,rdag&)}}
dag$=RIGHT$("00"+rdag$,2)
maand$=RIGHT$("00"+rmaand$,2)
jaar$=RIGHT$("????"+rjaar$,4)
datum$=dag$+"/"+maand$+"/"+jaar$
IF datum$<>"00/00/????" THEN
FOR n&=1 TO trpo
EXIT IF trouw&(n&,1)=volg&(t1%) AND trouw&(n&,2)=volg&(t2%)
NEXT n&
IF trouw&(n&,1)=volg&(t1%) AND trouw&(n&,2)=volg&(t2%) THEN
trouw&(n&,1)=volg&(t1%)
trouw&(n&,2)=volg&(t2%)
trouw$(n&)=datum$
ELSE
trouw&(trpo,1)=volg&(t1%)
trouw&(trpo,2)=volg&(t2%)
trouw$(trpo)=datum$
INC trpo
ENDIF
ELSE
FOR n&=1 TO trpo
IF trouw&(n&,1)=volg&(t1%) AND trouw&(n&,2)=volg&(t2%) THEN
FOR b&=n& TO trpo-1
trouw&(b&,1)=trouw&(b&+1,1)
trouw&(b&,2)=trouw&(b&+1,2)
trouw$(b&)=trouw$(b&+1)
NEXT b&
DEC trpo
ENDIF
NEXT n&
ENDIF
ENDIF
'
ENDIF
ENDIF
CLS
RETURN
> PROCEDURE voor
MENU KILL
CLS
~FORM_CENTER(dia5%,x&,y&,w&,h&)
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
CHAR{{OB_SPEC(dia5%,vlengte&)}}=STR$(sidelen&)
CHAR{{OB_SPEC(dia5%,gener&)}}=STR$(diepte%)
CHAR{{OB_SPEC(dia5%,paglen&)}}=STR$(page%)
CHAR{{OB_SPEC(dia5%,perfor&)}}=STR$(skip%)
IF opt=1 THEN
OB_STATE(dia5%,needat&)=BCLR(OB_STATE(dia5%,needat&),0)
OB_STATE(dia5%,jadat&)=BSET(OB_STATE(dia5%,jadat&),0)
ELSE
OB_STATE(dia5%,needat&)=BSET(OB_STATE(dia5%,needat&),0)
OB_STATE(dia5%,jadat&)=BCLR(OB_STATE(dia5%,jadat&),0)
ENDIF
IF rel! THEN
OB_STATE(dia5%,neerel&)=BCLR(OB_STATE(dia5%,neerel&),0)
OB_STATE(dia5%,jarel&)=BSET(OB_STATE(dia5%,jarel&),0)
ELSE
OB_STATE(dia5%,neerel&)=BSET(OB_STATE(dia5%,neerel&),0)
OB_STATE(dia5%,jarel&)=BCLR(OB_STATE(dia5%,jarel&),0)
ENDIF
IF extra! THEN
OB_STATE(dia5%,neeextra&)=BCLR(OB_STATE(dia5%,neeextra&),0)
OB_STATE(dia5%,jaextra&)=BSET(OB_STATE(dia5%,jaextra&),0)
ELSE
OB_STATE(dia5%,neeextra&)=BSET(OB_STATE(dia5%,neeextra&),0)
OB_STATE(dia5%,jaextra&)=BCLR(OB_STATE(dia5%,jaextra&),0)
ENDIF
IF trouw! THEN
OB_STATE(dia5%,neetro&)=BCLR(OB_STATE(dia5%,neetro&),0)
OB_STATE(dia5%,jatro&)=BSET(OB_STATE(dia5%,jatro&),0)
ELSE
OB_STATE(dia5%,neetro&)=BSET(OB_STATE(dia5%,neetro&),0)
OB_STATE(dia5%,jatro&)=BCLR(OB_STATE(dia5%,jatro&),0)
ENDIF
IF voor! THEN
OB_STATE(dia5%,neevoor&)=BCLR(OB_STATE(dia5%,neevoor&),0)
OB_STATE(dia5%,javoor&)=BSET(OB_STATE(dia5%,javoor&),0)
ELSE
OB_STATE(dia5%,neevoor&)=BSET(OB_STATE(dia5%,neevoor&),0)
OB_STATE(dia5%,javoor&)=BCLR(OB_STATE(dia5%,javoor&),0)
ENDIF
IF leef! THEN
OB_STATE(dia5%,neeleef&)=BCLR(OB_STATE(dia5%,neeleef&),0)
OB_STATE(dia5%,jaleef&)=BSET(OB_STATE(dia5%,jaleef&),0)
ELSE
OB_STATE(dia5%,neeleef&)=BSET(OB_STATE(dia5%,neeleef&),0)
OB_STATE(dia5%,jaleef&)=BCLR(OB_STATE(dia5%,jaleef&),0)
ENDIF
IF nlq! THEN
OB_STATE(dia5%,neenlq&)=BCLR(OB_STATE(dia5%,neenlq&),0)
OB_STATE(dia5%,janlq&)=BSET(OB_STATE(dia5%,janlq&),0)
ELSE
OB_STATE(dia5%,neenlq&)=BSET(OB_STATE(dia5%,neenlq&),0)
OB_STATE(dia5%,janlq&)=BCLR(OB_STATE(dia5%,janlq&),0)
ENDIF
IF formfeed! THEN
OB_STATE(dia5%,neeform&)=BCLR(OB_STATE(dia5%,neeform&),0)
OB_STATE(dia5%,jaform&)=BSET(OB_STATE(dia5%,jaform&),0)
ELSE
OB_STATE(dia5%,neeform&)=BSET(OB_STATE(dia5%,neeform&),0)
OB_STATE(dia5%,jaform&)=BCLR(OB_STATE(dia5%,jaform&),0)
ENDIF
DO
DO
~OBJC_DRAW(dia5%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia5%,0)
SELECT BCLR(a%,15)
CASE prefok&
OB_STATE(dia5%,prefok&)=BCLR(OB_STATE(dia5%,prefok&),0)
ENDSELECT
EXIT IF a%=prefok& OR a%=save&
LOOP
IF BTST(OB_STATE(dia5%,jadat&),0)
opt=1
ELSE
opt=2
ENDIF
IF BTST(OB_STATE(dia5%,jarel&),0)
rel!=TRUE
ELSE
rel!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,jaextra&),0)
extra!=TRUE
ELSE
extra!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,jatro&),0)
trouw!=TRUE
ELSE
trouw!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,javoor&),0)
voor!=TRUE
ELSE
voor!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,jaleef&),0)
leef!=TRUE
ELSE
leef!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,janlq&),0)
nlq!=TRUE
ELSE
nlq!=FALSE
ENDIF
IF BTST(OB_STATE(dia5%,jaform&),0)
formfeed!=TRUE
ELSE
formfeed!=FALSE
ENDIF
IF VAL(CHAR{{OB_SPEC(dia5%,gener&)}})<21 AND VAL(CHAR{{OB_SPEC(dia5%,gener&)}})>1 THEN
diepte%=VAL(CHAR{{OB_SPEC(dia5%,gener&)}})
ELSE
a%=0
ENDIF
IF VAL(CHAR{{OB_SPEC(dia5%,paglen&)}})<100 AND VAL(CHAR{{OB_SPEC(dia5%,paglen&)}})>9 THEN
page%=VAL(CHAR{{OB_SPEC(dia5%,paglen&)}})
ELSE
a%=0
ENDIF
IF VAL(CHAR{{OB_SPEC(dia5%,perfor&)}})<20 AND VAL(CHAR{{OB_SPEC(dia5%,perfor&)}})>=0 THEN
skip%=VAL(CHAR{{OB_SPEC(dia5%,perfor&)}})
ELSE
a%=0
ENDIF
IF VAL(CHAR{{OB_SPEC(dia5%,vlengte&)}})<50 AND VAL(CHAR{{OB_SPEC(dia5%,vlengte&)}})>=3 THEN
sidelen&=VAL(CHAR{{OB_SPEC(dia5%,vlengte&)}})
ELSE
a%=0
ENDIF
IF a%=save&
OPEN "o",#1,"STAMBOOM.INF"
PRINT #1;recht!
PRINT #1;naald9!
PRINT #1;maxrel
PRINT #1;opt
PRINT #1;rel!
PRINT #1;extra!
PRINT #1;trouw!
PRINT #1;voor!
PRINT #1;diepte%
PRINT #1;sidelen&
PRINT #1;leef!
PRINT #1;nlq!
PRINT #1;page%
PRINT #1;skip%
PRINT #1;formfeed!
CLOSE #1
OB_STATE(dia5%,save&)=BCLR(OB_STATE(dia5%,save&),0)
ENDIF
EXIT IF a%=prefok&
LOOP
SHOWM
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
RETURN
> PROCEDURE mot
MENU KILL
CLS
GOSUB res
GOSUB open_bar("Zoek 'Motje'.")
mot%=0
FOR nvm&=1 TO trpo-1
GOSUB bar(trpo,nvm&)
GOSUB volg_nummer(trouw&(nvm&,2))
kinpo=1
GOSUB zoek_kinderen(volg_nummer%,0)
FOR bvm&=1 TO kinpo-1
IF kinpo<>1 AND rel&(bvm&)<>0 AND @leeftijd(geb$(rel&(bvm&)))<>0 AND @leeftijd(geb$(rel&(bvm&)))-@leeftijd(trouw$(nvm&))<=270 THEN
INC mot%
sel2&(mot%)=trouw&(nvm&,2)
ENDIF
NEXT bvm&
NEXT nvm&
GOSUB close_bar
GOSUB sorteer_sel
GOSUB count_sel
PRINT CHR$(7);
ALERT 1," | "+STR$(select)+" 'Motjes' gevonden ! ",1," O.K. ",ant
RETURN
> PROCEDURE dia2
MENU KILL
CLS
GOSUB pick(" Van wie moet een breed diagram gemaakt worden ?"," PAS OP .... Alleen uitvoer naar printer via hardcopy")
IF nummer%<>0 THEN
GOSUB printer
ant=1
IF OUT?(0)=FALSE THEN
GOSUB kies("De printer staat niet aan. Doorgaan ?")
ENDIF
IF ant=1 THEN
skipcopy%=skip%
skip%=0
GOSUB printer
HIDEM
CLS
ERASE spread$(),spreadc$()
DIM spread$(diepte%),spreadc$(diepte%)
FOR n&=1 TO diepte%
spread$(n&)=MKI$(0)
NEXT n&
CLR maxdiepte%
GOSUB boom2(nummer%,1)
DEFTEXT ,,2700,
breed%=0
eerste%=100
GOSUB maakblok
GOSUB side
DEFTEXT ,,0,
SHOWM
skip%=skipcopy%
GOSUB printer
ENDIF
ENDIF
PRINT CHR$(7);
LET printboolean!=FALSE
ERASE spread$(),spreadc$()
RETURN
> PROCEDURE boom2(persoon%,gener%)
LOCAL vader%,moeder%,n&
maxdiepte%=MAX(maxdiepte%,gener%)
GOSUB zoek_vader(persoon%)
vader%=ant
GOSUB zoek_moeder(persoon%)
moeder%=ant
IF vader%<>0 AND moeder%<>0 THEN
FOR n&=gener% DOWNTO 1
spread$(n&)=LEFT$(spread$(n&),LEN(spread$(n&))-2)+MKI$(0)+RIGHT$(spread$(n&),2)
NEXT n&
ENDIF
spread$(gener%)=spread$(gener%)+MKI$(0)+MKI$(volg&(persoon%))
IF gener%>1 THEN
WHILE LEN(spread$(gener%))<LEN(spread$(gener%-1))
spread$(gener%)=LEFT$(spread$(gener%),LEN(spread$(gener%))-2)+MKI$(0)+RIGHT$(spread$(gener%),2)
WEND
ENDIF
IF gener%<diepte% THEN
IF vader%<>0 THEN
GOSUB boom2(vader%,gener%+1)
ENDIF
IF moeder%<>0 THEN
GOSUB boom2(moeder%,gener%+1)
ENDIF
ENDIF
RETURN
> PROCEDURE side
offset%=0
wijd%=640/MIN(diepte%,maxdiepte%)
REPEAT
offset!=TRUE
FOR nm&=1 TO diepte%
spreadc$(nm&)=spread$(nm&)
NEXT nm&
FOR nm&=5 TO breed% STEP 2
FOR bm&=1 TO maxdiepte%
IF LEN(spread$)<nm& THEN
persoon%=CVI(MID$(spread$(bm&),nm&,2))
IF persoon%<>0 THEN
GOSUB volg_nummer(persoon%)
persoon%=volg_nummer%
x%=wijd%*(bm&-1)+2
y%=offset%+9*sidelen&*((nm&-eerste%)/4)+10
x1%=x%-2
y2%=y%+8*sidelen&+2
y1%=y%-1
x2%=x%+10
IF voor! THEN
pr$=voor$(volg_nummer%)+" "+naam$(volg_nummer%)+" "+geb$(volg_nummer%)
IF LEN(pr$)>sidelen& THEN
pr$=voor$(volg_nummer%)+" "+naam$(volg_nummer%)+" "+RIGHT$(geb$(volg_nummer%),4)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(voor$(volg_nummer%),1)+"."+naam$(volg_nummer%)+" "+geb$(volg_nummer%)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(LEFT$(voor$(volg_nummer%),1)+"."+naam$(volg_nummer%)+SPACE$(sidelen&),sidelen&)
ENDIF
ENDIF
ENDIF
ELSE
pr$=naam$(volg_nummer%)+" "+geb$(volg_nummer%)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(naam$(volg_nummer%)+SPACE$(sidelen&),sidelen&)
ENDIF
ENDIF
TEXT x%,y%,pr$
BOX x1%,y1%,x2%,y2%
IF y2%>=200*res& THEN
offset!=FALSE
ENDIF
IF bm&<diepte% THEN
'
xf%=x%+10
yf%=(y1%+y2%)/2
GOSUB zoek_vader(volg_nummer%)
vader%=ant
IF ant<>0 THEN
FOR mm&=1 TO LEN(spreadc$(bm&+1)) STEP 2
EXIT IF CVI(MID$(spreadc$(bm&+1),mm&,2))=volg&(ant)
NEXT mm&
IF CVI(MID$(spreadc$(bm&+1),mm&,2))=volg&(ant) THEN
xt%=wijd%*(bm&)-1
yt1%=offset%+9*sidelen&*((mm&-eerste%)/4)+10
yt2%=yt1%+8*sidelen&+2
yt1%=yt1%-1
yt%=(yt1%+yt2%)/2
LINE xf%,yf%,xf%+3,yf%
LINE xf%+3,yf%,xt%-3,yt%
LINE xt%-3,yt%,xt%,yt%
ytr%=yt%
MID$(spreadc$(bm&+1),mm&,2)=MKI$(0)
ENDIF
ENDIF
GOSUB zoek_moeder(persoon%)
moeder%=ant
IF ant<>0 THEN
FOR mm&=1 TO LEN(spreadc$(bm&+1)) STEP 2
EXIT IF CVI(MID$(spreadc$(bm&+1),mm&,2))=volg&(ant)
NEXT mm&
IF CVI(MID$(spreadc$(bm&+1),mm&,2))=volg&(ant) THEN
xt%=wijd%*(bm&)-1
yt1%=offset%+9*sidelen&*((mm&-eerste%)/4)+10
yt2%=yt1%+8*sidelen&+2
yt1%=yt1%-1
yt%=(yt1%+yt2%)/2
LINE xf%,yf%,xf%+3,yf%
LINE xf%+3,yf%,xt%-3,yt%
LINE xt%-3,yt%,xt%,yt%
ytr%=(ytr%+yt%)/2
MID$(spreadc$(bm&+1),mm&,2)=MKI$(0)
ENDIF
ENDIF
IF moeder%<>0 AND vader%<>0 AND trouw! THEN
FOR vm&=1 TO trpo-1
IF trouw&(vm&,1)=volg&(vader%) AND trouw&(vm&,2)=volg&(moeder%) THEN
DEFTEXT ,,,4
TEXT xt%-6,ytr%-30,trouw$(vm&)
DEFTEXT ,,,6
ENDIF
NEXT vm&
ENDIF
'
ENDIF
ENDIF
ENDIF
NEXT bm&
NEXT nm&
IF printboolean!=TRUE THEN
key$=INKEY$
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
IF offset1!=FALSE THEN
GOSUB hardcopy
ENDIF
key$=INKEY$
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
ELSE
REPEAT
key$=INKEY$
UNTIL key$<>"" OR MOUSEK<>0
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
ENDIF
CLS
SUB offset%,200*res&
UNTIL offset1!=TRUE OR offset!=TRUE
IF printboolean!=TRUE THEN
IF formfeed! THEN
GOSUB lprint("")
ENDIF
LPRINT "@"
ENDIF
RETURN
PROCEDURE fam
staat!=TRUE
MENU KILL
CLS
GOSUB pick(" Van wie moet een familiestaat gemaakt worden ?",sort$)
IF nummer%<>0 THEN
ant1=FORM_ALERT(1,"[2][ | Welke familiestaat wilt U ? ][ Enkele | Meerdere ]")
GOSUB kies("Moet dit geprint worden ?")
IF ant=1 THEN
GOSUB printer
ENDIF
IF printboolean!=FALSE AND ant=1
ant=FORM_ALERT(1,"[1][ | De printer staat niet online ! ][ Doorgaan | Afbreken ]")
GOSUB printer
ENDIF
SELECT ant1
CASE 1
GOSUB make_staat(nummer%)
GOSUB uitdraai
IF formfeed! AND printboolean! THEN
GOSUB lprint("")
ENDIF
PRINT " Druk op een toets."
REPEAT
UNTIL MOUSEK<>0 OR INKEY$<>""
CASE 2
GOSUB boom3(nummer%)
IF formfeed! AND printboolean! THEN
GOSUB lprint("")
ENDIF
ENDSELECT
ENDIF
staat!=FALSE
LET printboolean!=FALSE
RETURN
> PROCEDURE boom3(in&)
GOSUB make_staat(in&)
GOSUB uitdraai
GOSUB zoek_moeder(in&)
IF ant<>0 THEN
GOSUB boom3(ant)
ENDIF
GOSUB zoek_vader(in&)
IF ant<>0 THEN
GOSUB boom3(ant)
ENDIF
RETURN
> PROCEDURE make_staat(in&)
ARRAYFILL bc&(),0
stpo%=1
bc&(stpo%,1)=in&
bc&(stpo%,2)=1
INC stpo%
kinpo=1
GOSUB zoek_kinderen(in&,0)
FOR nmb&=1 TO kinpo-1
kinpoc=kinpo
relc&(nmb&)=rel&(nmb&)
NEXT nmb&
GOSUB zoek_relatie(in&)
IF ant<>0 THEN
FOR nmb&=1 TO relpo-1
bc&(stpo%,1)=rel&(nmb&)
bc&(stpo%,2)=2
INC stpo%
NEXT nmb&
IF relpo<>1 THEN
FOR nmb&=2 TO relpo
ARRAYFILL rel&(),0
kinpo=1
GOSUB zoek_kinderen(bc&(nmb&,1),0)
IF kinpo<>1 THEN
FOR vmb&=1 TO kinpo-1
FOR mmb&=1 TO kinpoc-1
IF relc&(mmb&)=rel&(vmb&) THEN
relc&(mmb&)=0
bc&(stpo%,1)=rel&(vmb&)
bc&(stpo%,2)=3
bc&(stpo%,3)=nmb&
INC stpo%
ENDIF
NEXT mmb&
NEXT vmb&
ENDIF
NEXT nmb&
ENDIF
ENDIF
FOR nmb&=1 TO kinpoc-1
IF relc&(nmb&)<>0 THEN
bc&(stpo%,1)=relc&(nmb&)
bc&(stpo%,2)=3
bc&(stpo%,3)=1
INC stpo%
ENDIF
NEXT nmb&
RETURN
> PROCEDURE uitdraai
CLS
PRINT " "+STRING$(78,"*")
lprint(" "+STRING$(78,"*"))
FOR n&=1 TO stpo%-1
SELECT bc&(n&,2)
CASE 1
CLR pr$
pr$=voor$(bc&(n&,1))+" "+naam$(bc&(n&,1))
IF LEN(pr$)>28 THEN
pr$=LEFT$(voor$(bc&(n&,1)),1)+"."+naam$(bc&(n&,1))
ENDIF
dummy$=LEFT$(pr$+STRING$(40,"-"),29)+geb$(bc&(n&,1))+" "
IF bc&(n&+1,2)<>2 THEN
GOSUB lprint(dummy$)
PRINT dummy$
GOSUB lprint(" ")
PRINT
ENDIF
CASE 2
pr$=voor$(bc&(n&,1))+" "+naam$(bc&(n&,1))
IF LEN(pr$)>28 THEN
pr$=LEFT$(voor$(bc&(n&,1)),1)+"."+naam$(bc&(n&,1))
ENDIF
IF dummy$="" THEN
dummy$=SPACE$(40)
ENDIF
pr$=dummy$+LEFT$(pr$+STRING$(40,"-"),29)+geb$(bc&(n&,1))
PRINT pr$
GOSUB lprint(pr$)
IF trouw! THEN
FOR b&=1 TO trpo-1
IF ges$(bc&(n&,1))="V" THEN
IF trouw&(b&,1)=volg&(bc&(1,1)) AND trouw&(b&,2)=volg&(bc&(n&,1)) THEN
PRINT TAB(35);trouw$(b&)
GOSUB lprint(SPACE$(35)+trouw$(b&))
ENDIF
ELSE
IF trouw&(b&,2)=volg&(bc&(1,1)) AND trouw&(b&,1)=volg&(bc&(n&,1)) THEN
PRINT TAB(35);trouw$(b&)
GOSUB lprint(SPACE$(35)+trouw$(b&))
ENDIF
ENDIF
NEXT b&
ENDIF
PRINT
GOSUB lprint(" ")
FOR b&=n& TO stpo%-1
IF bc&(b&,2)=3 AND bc&(b&,3)=n& THEN
pr$=voor$(bc&(b&,1))+" "+naam$(bc&(b&,1))
IF LEN(pr$)>48 THEN
pr$=LEFT$(voor$(bc&(b&,1)),1)+"."+naam$(bc&(b&,1))
ENDIF
pr$=LEFT$(pr$+STRING$(60,"-"),49)+geb$(bc&(b&,1))
PRINT TAB(10);pr$
GOSUB lprint(SPACE$(10)+pr$)
bc&(b&,2)=0
ENDIF
NEXT b&
PRINT
GOSUB lprint(" ")
CLR pr$,dummy$
CASE 3
pr$=voor$(bc&(n&,1))+" "+naam$(bc&(n&,1))
IF LEN(pr$)>48 THEN
pr$=LEFT$(voor$(bc&(n&,1)),1)+"."+naam$(bc&(n&,1))
ENDIF
pr$=LEFT$(pr$+STRING$(60,"-"),49)+geb$(bc&(n&,1))
PRINT TAB(10);pr$
GOSUB lprint(SPACE$(10)+pr$)
CLR pr$,dummy$
ENDSELECT
NEXT n&
PRINT " "+STRING$(78,"*")
lprint(" "+STRING$(78,"*"))
RETURN
> PROCEDURE datum
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
~FORM_CENTER(dia7%,x&,y&,w&,h&)
CHAR{{OB_SPEC(dia7%,djaar&)}}=""
CHAR{{OB_SPEC(dia7%,dmaand&)}}=""
CHAR{{OB_SPEC(dia7%,ddag&)}}=""
~FORM_DIAL(0,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(1,320,200,20,20,x&,y&,w&,h&)
DO
~OBJC_DRAW(dia7%,0,7,x&,y&,w&,h&)
a%=FORM_DO(dia7%,0)
SELECT BCLR(a%,15)
CASE datok&
datmaand$=CHAR{{OB_SPEC(dia7%,dmaand&)}}
datdag$=CHAR{{OB_SPEC(dia7%,ddag&)}}
IF VAL(datmaand$)>12 OR VAL(datdag$)>31 THEN
a%=0
STOP
ENDIF
OB_STATE(dia7%,datok&)=BCLR(OB_STATE(dia7%,datok&),0)
ENDSELECT
EXIT IF a%=datok&
LOOP
OB_STATE(dia7%,datok&)=BCLR(OB_STATE(dia7%,datok&),0)
SHOWM
~FORM_DIAL(2,320,200,20,20,x&,y&,w&,h&)
~FORM_DIAL(3,320,200,20,20,x&,y&,w&,h&)
datjaar$=CHAR{{OB_SPEC(dia7%,djaar&)}}
datmaand$=CHAR{{OB_SPEC(dia7%,dmaand&)}}
datdag$=CHAR{{OB_SPEC(dia7%,ddag&)}}
SETTIME TIME$,datdag$+"."+datmaand$+"."+datjaar$
DEFFILL 1,2,4
PBOX -1,-1,641,401
DEFFILL 1,1
RETURN
> PROCEDURE hardcopy
CLR key$
IF nlq! AND naald9! THEN
FOR yp&=0 TO 198*res& STEP 8
CLR pr$
FOR xp&=0 TO 639
CLR out&
FOR o&=0 TO 7
IF POINT(xp&,yp&+o&)
out&=out&+2^(7-o&)
ENDIF
NEXT o&
pr$=pr$+CHR$(out&)
NEXT xp&
FOR o&=LEN(pr$) DOWNTO 1
EXIT IF MID$(pr$,o&,1)<>CHR$(0)
NEXT o&
pr$=LEFT$(pr$,o&)
LET init$="*"+CHR$(4)+CHR$(o& MOD 256)+CHR$(o& DIV 256)
IF GEMDOS(17)=FALSE THEN
ALERT 2," | De printer staat niet aan. ",1," Print | Cancel ",ant
IF ant=2 THEN
KEYPRESS 27
LET printboolean!=FALSE
ENDIF
ENDIF
key$=INKEY$
EXIT IF ASC(key$)=27
IF GEMDOS(17)=FALSE THEN
ENDIF
LPRINT "A"+init$+pr$+"3"+CHR$(1)+CHR$(13)+init$+pr$+"3"+CHR$(1)+CHR$(13)+"A"+"";
NEXT yp&
ELSE
HARDCOPY
ENDIF
IF ASC(key$)=27 THEN
KEYPRESS 27
ENDIF
RETURN
> PROCEDURE maakblok
eerste%=1000000
FOR n&=1 TO maxdiepte%
FOR b&=1 TO LEN(spread$(n&)) STEP 2
EXIT IF CVI(MID$(spread$(n&),b&,2))<>0
NEXT b&
IF CVI(MID$(spread$(n&),b&,2))<>0 THEN
eerste%=MIN(eerste%,b&)
ENDIF
breed%=MAX(LEN(spread$(n&)),breed%)
NEXT n&
FOR n&=1 TO maxdiepte%
spread$(n&)=LEFT$(spread$(n&)+STRING$(breed%,CHR$(0)),breed%)
NEXT n&
REPEAT
flag2!=FALSE
flag!=FALSE
FOR n&=breed%-1 TO eerste% STEP -2
FOR b&=1 TO maxdiepte%
EXIT IF CVI(MID$(spread$(b&),n&,2))<>0
NEXT b&
IF b&>maxdiepte%
IF flag!=FALSE THEN
flag!=TRUE
ELSE
flag2!=TRUE
FOR b&=1 TO maxdiepte%
spread$(b&)=LEFT$(spread$(b&),n&-1)+RIGHT$(spread$(b&),LEN(spread$(b&))-n&-1)
NEXT b&
SUB n&,2
ENDIF
ELSE
flag!=FALSE
ENDIF
NEXT n&
breed%=LEN(spread$(1))
UNTIL flag2!=FALSE
RETURN
> PROCEDURE dia3
MENU KILL
CLS
GOSUB pick(" Van wie moet een naar beneden lopend diagram gemaakt worden ?"," PAS OP .... Alleen uitvoer naar printer via hardcopy")
IF nummer%<>0 THEN
kinpo=1
GOSUB zoek_kinderen(nummer%,nummer%)
IF kinpo=1 THEN
ALERT 1,"De door U aangewezen persoon | heeft geen kinderen. | | Functie zinloos. ",1," O.K. ",ant
ELSE
GOSUB printer
ant=1
IF OUT?(0)=FALSE THEN
GOSUB kies("De printer staat niet aan. Doorgaan ?")
ENDIF
IF ant=1 THEN
skipcopy%=skip%
skip%=0
CLR maxdiepte%,lastmm&
GOSUB printer
HIDEM
CLS
ERASE spread$(),spreadc$()
DIM spread$(diepte%),spreadc$(diepte%)
FOR n&=1 TO diepte%
spread$(n&)=STRING$(4,MKI$(0))
NEXT n&
spread$(1)=spread$(1)+MKI$(nummer%)+MKI$(0)
'
FOR nm&=1 TO diepte%-1
bm&=1
WHILE bm&<LEN(spread$(nm&))-2
mm&=CVI(MID$(spread$(nm&),bm&,2))
IF mm&<>lastmm& AND mm&<>0 THEN
lastmm&=mm&
kinpo=1
ARRAYFILL rel&(),0
GOSUB zoek_kinderen(mm&,0)
IF kinpo<>1 THEN
maxdiepte%=MAX(maxdiepte%,nm&+1)
IF LEN(spread$(nm&+1))<LEN(spread$(nm&))
bmle&=LEN(spread$(nm&))
bmle&=bmle&-ODD(bmle&)
spread$(nm&+1)=LEFT$(spread$(nm&+1)+STRING$(500,MKI$(0)),bmle&)
ENDIF
FOR vm&=1 TO kinpo-1
spread$(nm&+1)=spread$(nm&+1)+MKI$(rel&(vm&))+MKI$(0)
NEXT vm&
spread$(nm&+1)=spread$(nm&+1)+MKI$(0)
bmst&=LEN(spread$(nm&+1))-4*(kinpo-1)-1
bmle&=4*(kinpo-1)+EVEN(kinpo)
CLR space1$
IF bmst&>bm& THEN
space1$=STRING$((bmst&-bm&) DIV 2,MKI$(0))
ENDIF
IF recht!=FALSE
space1$=space1$+STRING$(bmle& DIV 4,MKI$(0))
ENDIF
FOR nbm&=nm& DOWNTO 1
IF LEN(spread$(nbm&))>bm&-1 THEN
hulp1$=LEFT$(spread$(nbm&),bm&-1)
hulp2$=RIGHT$(spread$(nbm&),LEN(spread$(nbm&))-bm&-1)
hulp3$=MID$(spread$(nbm&),bm&,2)
spread$(nbm&)=hulp1$+space1$+hulp3$+hulp2$
ENDIF
NEXT nbm&
ENDIF
ENDIF
ADD bm&,2
WEND
NEXT nm&
'
GOSUB maakblok
'
GOSUB side2
'
skip%=skipcopy%
GOSUB printer
ENDIF
ENDIF
ENDIF
LET printboolean!=FALSE
PRINT CHR$(7);
ERASE spread$(),spreadc$()
RETURN
> PROCEDURE side2
DEFTEXT ,,2700,
offset%=0
wijd%=640/MIN(diepte%,maxdiepte%)
REPEAT
offset!=TRUE
FOR nm&=1 TO diepte%
spreadc$(nm&)=spread$(nm&)
NEXT nm&
FOR nm&=eerste% TO breed% STEP 2
FOR bm&=1 TO maxdiepte%
IF LEN(spread$)<nm& THEN
persoon%=CVI(MID$(spread$(bm&),nm&,2))
IF persoon%<>0 THEN
x%=625-wijd%*(bm&-1)+2
y%=offset%+18*sidelen&*((nm&-eerste%)/4)+10
x1%=x%-2
y2%=y%+8*sidelen&+2
y1%=y%-1
x2%=x%+10
IF voor! THEN
pr$=voor$(persoon%)+" "+naam$(persoon%)+" "+geb$(persoon%)
IF LEN(pr$)>sidelen& THEN
pr$=voor$(persoon%)+" "+naam$(persoon%)+" "+RIGHT$(geb$(persoon%),4)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(voor$(persoon%),1)+"."+naam$(persoon%)+" "+geb$(persoon%)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(LEFT$(voor$(persoon%),1)+"."+naam$(persoon%)+SPACE$(sidelen&),sidelen&)
ENDIF
ENDIF
ENDIF
ELSE
pr$=naam$(persoon%)+" "+geb$(persoon%)
IF LEN(pr$)>sidelen& THEN
pr$=LEFT$(naam$(persoon%)+SPACE$(sidelen&),sidelen&)
ENDIF
ENDIF
TEXT x%,y%,pr$
BOX x1%,y1%,x2%,y2%
IF y2%>=200*res& THEN
offset!=FALSE
ENDIF
IF bm&<diepte% THEN
'
kinpo=1
ARRAYFILL rel&(),0
zoek_kinderen(persoon%,0)
IF kinpo<>1 THEN
FOR nmb&=1 TO kinpo-1
mm&=INSTR(spreadc$(bm&+1),MKI$(rel&(nmb&)))
'
IF mm&<>0 THEN
xt%=625-(wijd%*(bm&)-12)
yt1%=offset%+18*sidelen&*((mm&-eerste%)/4)+10
yt2%=yt1%+8*sidelen&+2
yt1%=yt1%-1
yt%=(yt1%+yt2%)/2
xm%=(xt%+x1%)/2
LINE x1%,(y1%+y2%)/2,xm%,(y1%+y2%)/2
LINE xt%,yt%,xm%,yt%
LINE xm%,(y1%+y2%)/2,xm%,yt%
MID$(spreadc$(bm&+1),mm&,2)=MKI$(0)
ENDIF
'
NEXT nmb&
ENDIF
'
ENDIF
ENDIF
ENDIF
NEXT bm&
NEXT nm&
IF printboolean!=TRUE THEN
key$=INKEY$
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
IF offset1!=FALSE THEN
GOSUB hardcopy
ENDIF
key$=INKEY$
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
ELSE
REPEAT
key$=INKEY$
UNTIL key$<>"" OR MOUSEK<>0
IF ASC(key$)=27 THEN
offset1!=TRUE
ENDIF
ENDIF
CLS
SUB offset%,200*res&
UNTIL offset!=TRUE OR offset1!=TRUE
IF GEMDOS(17)=TRUE THEN
IF formfeed! THEN
GOSUB lprint("")
ENDIF
LPRINT "@"
ENDIF
DEFTEXT ,,0,
RETURN
> PROCEDURE ver
MENU KILL
CLS
GOSUB pick(" Wie moet er vervangen worden ?"," PAS OP Dit persoon wordt verwijderd !!!")
IF nummer%<>0 THEN
t1%=nummer%
GOSUB pick(" Vervang "+naam$(nummer%)+" "+voor$(nummer%)+" "+geb$(nummer%)," voor ....")
t2%=nummer%
IF nummer%<>0 THEN
CLR tel%
FOR n&=1 TO maxrel
EXIT IF index&(t1%,n&,2)=0
IF index&(t1%,n&,1)<>0 THEN
INC tel%
ENDIF
NEXT n&
CLR start&
FOR n&=1 TO maxrel
EXIT IF index&(t1%,n&,2)=0
IF index&(t2%,n&,1)<>0 THEN
INC tel%
start&=n&
ENDIF
NEXT n&
IF tel%>maxrel THEN
ALERT 3," | Er bestaan teveel relaties | tussen deze personen. ",1," Sorry ",ant
ELSE
HIDEM
CLS
PRINT " Aan "+naam$(t2%)+" "+voor$(t2%)+" "+geb$(t2%)
PRINT " word(en) de volgende mens(en) toegevoegd."
FOR nmb&=1 TO maxrel
EXIT IF index&(t1%,nmb&,2)=0
index&(t2%,nmb&+start&,1)=index&(t1%,nmb&,1)
index&(t2%,nmb&+start&,2)=index&(t1%,nmb&,2)
GOSUB volg_nummer(index&(t1%,nmb&,1))
PRINT " "+naam$(volg_nummer%)+" "+voor$(volg_nummer%)+" "+geb$(volg_nummer%)
NEXT nmb&
PRINT
PRINT " De volgende personen worden van :"
PRINT " "+naam$(t1%)+" "+voor$(t1%)+" "+geb$(t1%)+" naar ..."
PRINT " "+naam$(t2%)+" "+voor$(t2%)+" "+geb$(t2%)+" geexporteerd."
PRINT
FOR nmb&=1 TO last&
FOR nmv&=1 TO maxrel
EXIT IF index&(nmb&,nmv&,2)=0
IF index&(nmb&,nmv&,1)=volg&(t1%) THEN
index&(nmb&,nmv&,1)=volg&(t2%)
PRINT " "+naam$(nmb&)+" "+voor$(nmb&)+" "+geb$(nmb&)
ENDIF
NEXT nmv&
NEXT nmb&
PRINT
nummer%=t1%
volg=volg&(nummer%)
GOSUB delete1
PRINT
PRINT
PRINT CHR$(7);
sort!=FALSE
GOSUB sorteer
PRINT " Druk op een toets."
REPEAT
UNTIL MOUSEK<>0 OR INKEY$<>""
SHOWM
ENDIF
ENDIF
ENDIF
RETURN