This program is Copyright 1993, 1997 Denis Howe. You may distribute verbatim or modified copies of this program provided each such copy is distributed with a copyright notice and distribution conditions identical to these. Please send me a copy of any changes you make and update the modification history at the end of !Help. Denis Howe Task$ = "Family" #Purpose$ = "Family tree editor" "Author$ = " 1993 Denis Howe" #Version$ = "2.17 (09 Jun 1997)" Initialise some variables for PROCError & PROCQuit :Task%=0:Modified%= :Font%=0:ExtEdJob%=0 Error: ================== User-customisable variables =================== Maximum completions to show in Comp window MaxComp%=25 Maximum spouses in divorce menu MaxSpouse%=10 Maximum depth of tree displayed MaxGen%=20 Maximum GEDCOM structure depth MaxLevel%=20 MTLoad(".Messages") Allocate the heap by lowering HIMEM below the WimpSlot, making sure there are VarSize% bytes left above END for further variables, DIMs and strings. (.VarSize%=40000:Heap%= +VarSize%:HeapEnd%= Heap%>=HeapEnd% MT("NR") =Heap% : Can't do this in a PROC +7Heap%= : Read back actual value Init : Misc one-off initialisation CrMenu : Create menus InitTags : Set up GEDCOM tags structures PROCSyntax :REM Load GEDCOM syntax description Reset : Reset heap and database Args : Check for cmd line args ========================== Main loop ============================= Error : Falls back into poll loop CheckFree Modified Force% Force : Update display "Wimp_Poll",&1831,b% Redraw "Wimp_OpenWindow",,b% "Wimp_CloseWindow",,b% @. !b%=MainWH% Close(NoteWH%): OpenDir DragDone Buttons(!b%,b%!4,b%!8,b%!12,b%!16) Key(!b%,b%!4,b%!24) MenuClick(b%!0,b%!4,b%!8,b%!12) 17,18: Receive(b%!0,b%!4,b%!8,b%!16) RcvAck(b%!0,b%!4,b%!16) ===================== GEDCOM access functions ==================== Return an object's value after stripping the reference flag Val(O%)=O%!ObVal% ObRef% Create a new object with Tag% and Value% Object(Tag%,Value%) Alloc(ObSize%) U=O%!ObTag%=Tag%:O%!ObVal%=Value%:O%!ObSubs%=0:O%!ObNext%=0 Convert null pointer to empty string Null(P%) Return a string to print O%'s value - either its string value or a cross-reference Id. PrintStr(O%) V%:V%=O%!ObVal% ObRef% Id(V% ObRef%) Null(V%) Get the string value of O%'s first sub-object with Tag% or "" if there is no such value GetStr(O%,Tag%)= Null( GetVal(O%,Tag%)) Return the value of object O%'s first sub-object with Tag% or 0 if there is no such object GetVal(O%,Tag%) S%:S%=0 GetSub(O%,Tag%,S%) S%= Val(S%) If S%=0 return O%'s first sub-object with Tag% else return the next one GetSub(O%,Tag%, O%=0 1,"FNGetSub" S% S%=S%!ObNext% S%=O%!ObSubs% S%!ObTag%=Tag% S%=S%!ObNext% Ensure that O% has a sub-object with Tag% and Val$ or none if Val$="". If Single% then overwrite any exiting Tag% sub- object otherwise add a new one. Deallocate any previous value. SetStr(O%,Tag%,Val$,Single%) O$,V%,S% O%=0 1,"PROCSetStr" Val$="" DelTag(O%,Tag%): GetSub(O%,Tag%,S%) 1 V%=S%!ObVal%: (V% ObRef%)=0 $V%=Val$ Single% ) Free(V%):S%!ObVal%= String(Val$) Modified%= Tail(O%)= Object(Tag%, String(Val$)) Modified%= Ensure that O% has a sub-object with Tag% and Val%. Single% => overwrite any existing Tag% sub-object else add a new one. Don't deallocate referend of any previous value (which may not be a pointer). SetSub(O%,Tag%,Val%,Single%) O%=0 1,"PROCSetSub" GetSub(O%,Tag%,S%) S%!ObVal%=Val% Single% S%!ObVal%=Val%:Modified%= Tail(O%)= Object(Tag%,Val%) Modified%= Return the address of the last ObNext% in P%'s sub-object list Tail(P%) )P%=P%+ObSubs%: !P%:P%=!P%+ObNext%: ======================= Remove, Delete, Kill ===================== Remove => unlink the object from some given place but don't free it. Delete => remove it and free it and its string value. Kill => delete it and remove any cross-references to it. Delete object Victim%, its sub-objects and all cross-references to it from other objects. Also remove objects which are only referred to from Victim%. These may be shared so we have to traverse the whole database several times to determine what's still live. Kill(Victim%) Victim%=0 Mark(Victim%) Scan(Root%): Modified%= :Force%=1 Mark object O% and its sub-objects by setting the Dead% bit in their tag pointers (not their tag flags) Mark(O%) O%!ObTag%=O%!ObTag% Dead% 1O%=O%!ObSubs%: Mark(O%):O%=O%!ObNext%: Mark as dead any sub-object of O% which is a cross-reference to a dead object. Recurse on its sub-objects. If any sub-object is marked as dead, free it and remove it from the list. If a FAM object is left with less than 2 sub-objects then remove it. Return Dead% if any object died. Scan(O%) D%,P%,S%,V% P%=O%+ObTag%:V%=O%!ObVal% ObRef% V%=V% ObRef% Dead x-ref - mark O% dead V%!ObTag% Dead% !P%=!P% Dead% D%=!P% Dead%:P%=O%+ObSubs% S%=!P%:D%=D% Scan(S%) S%!ObTag% Dead% FreeOb(S%) !P%=S%!ObNext% P%=S%+ObNext% P%=O%+ObTag% (!P% Dead%)=FamTg% S%=O%!ObSubs% S%!ObNext% !P%=!P% Dead%:D%=Dead% Free object O% and its value (if a string) but not its sub- objects. If it's a display structure pointer, free the name. FreeOb(O%) V%:V%=O%!ObVal% (O%!ObTag% Dead%)=DispTg% Free(V%!DSName%) (V% ObRef%)=0 Free(V%) Free(O%) Remove O%'s first sub-object with Tag% and Val% but don't free it RemSub(O%,Tag%,Val%) O%=0 Val%=0 1,"PROCRemSub" P%=O%+ObSubs% O%=!P% O%!ObTag%=Tag% 6 Val(O%)=Val% !P%=O%!ObNext%:Modified%= P%=O%+ObNext% Remove S% from O%'s sub-object list RemSubObj(O%,S%) O%=O%+ObSubs% !O%=S% !O%=S%!ObNext%: O%=!O%+ObNext% Remove all O%'s sub-objects with Tag% DelTag(O%,Tag%) O%=0 1,"PROCDelTag" P%=O%+ObSubs% O%=!P% O%!ObTag%=Tag% " !P%=O%!ObNext%: DelObj(O%) P%=O%+ObNext% Remove object O% and its sub-objects DelObj(O%) FreeOb(O%) 3O%=O%!ObSubs%: DelObj(O%):O%=O%!ObNext%: =========================== Display ============================== Wimp requests redraw Redraw XW%,YW%,M%,P%,WH% "Wimp_RedrawWindow",,b% $9WH%=!b%:XW%=b%!4-b%!20:YW%=b%!16-b%!24 : Work origin WH%=MainWH% TopChil%=0 WH% MainWH%: Display(b%!28-XW%,b%!32-YW%,b%!36-XW%,b%!40-YW%,OutScreen%) CompWH%: DrawComp(XW%,YW%) NoteWH%: DrawNote(XW%,YW%) ObEdWH%: DrawObEd(XW%,YW%,b%!32,b%!40) 1,"PROCRedraw" "Wimp_GetRectangle",,b% Something in the main window has changed. Recalculate all positions and the extent. Force F%,O%,X%,Y% UseFont%=ScreenUseFont% CalcAll Close(MainWH%) yMax%>yMin% ;, b%!0=(xMin%-32) 7:b%!4=yMin% <0 b%!8=(xMax%+7) 7:b%!12=(yMax%+7) "Wimp_SetExtent",MainWH%,b% ?-b%!0=MainWH%: "Wimp_GetWindowState",,b% Force%>1 TopChil%>0 Find the Chil object pointing to Person% F%=0:O%=0 GetSub(Person%,FamcTg%,F%) F%= Val(F%):X%=0 E. GetSub(F%,ChilTg%,O%) X%= Val(O%) O%=0 X%=Person% O%=0 O%=TopChil% GetPos(O%,X%,Y%) : Scroll to show Person% b%!20=X%-(b%!12-b%!4) b%!24=Y%+(b%!16-b%!8) b%!8-=Infinity%:b%!12+=Infinity% :REM Max window down right "Wimp_OpenWindow",,b% Force%=0 Ensure menu on top if open Menu% "Wimp_CreateMenu",,Menu%,MenuX%,MenuY% Get the display position of a CHIL object. A CHIL's first subobject always points to its display structure. GetPos(C%, C%=0 1,"PROCGetPos" C%=C%!ObSubs% C%=C%!ObVal% X%=C%!DSx%:Y%=C%!DSy% Name(P%)= GetStr(P%,NameTg%) If N$ contains two '/'s return the string between them. Otherwise return the last word preceded by a space or nothing if no such word. Ignore anything after a non-initial '(' or '['. FamName(N$) B%,E%,S% N$="" Check for GEDCOM family name between '/'s N$,"/") S% S%+=1:E%= N$,"/",S%): N$,S%,E%-S%) j&B%= N$,"(",2): B%=0 B%= N$,"[",2) B% N$= N$,B%-1) N$,1)=" ":N$= (N$)-1): N$," "): S% N$= N$,S%+1):B%= S%=0 Return P%'s dates string. Show "?" for missing d.o.b. but nothing for death (would suggest person is dead). Dates(P%) D$,W$ Birth(P%) D$>"" W$= Year(D$) W$="?" W$+=" -" Death(P%) D$>"" W$+=" "+ Year(D$) Return date from last group of digits to end Year(D$) ShowYearOnly% E%>1 Digit( D$,E%,1)) % E%-=1: Digit( D$,E%,1)) = D$,E%+1) E%-=1 Alpha(C$) C%:C%= (C$) =C%>= C%<= Digit(C$)=C$>="0" C$<="9" ===================== Calculate positions ======================== Calculate work coords of Person%'s family. Set global work area (xMin%,yMin%) to (xMax%,yMax%). Global UseFont% determines string widths. CalcAll DS%,H%,I%,P%,S%,Y0% "Font_SetFont",Font% : Affects widths HGap%= Width("XX") : Horiz. space between adjacent people UseFont% "Font_ReadInfo",Font% ,,Y0%,,H%:H%-=Y0% H%=CharH% LineHeight%=H%+8 1xMin%=0:yMin%=0:xMax%=MinW%:yMax%=0:xMax%()=0 Person%=0 TopChil%=0: Error here (e.g. out of memory) is fatal Fake a CHIL object to point to the person at the top of the tree. Attach the top level display structure to it. ,TopChil%= Object(ChilTg%, Fore(Person%)) DStruct(TopChil%) S%=TopChil%:P%=0 S%>1 S%!ObTag% HusbTg%,WifeTg%,ChilTg% D DS%= DStruct(S%) : Give every member a display struct 6 DS%!DSx%=Infinity% : Everyone off screen DS%!DSy%=-Infinity% S%=S%!ObNext% S%=0 7 GetSub(Root%,FamTg%,P%) S%=P%!ObSubs% S%=1 "Hourglass_On" Calc(TopChil%,0,0,z,xMin%,xMax%) "Hourglass_Off" Max(xMax%,MinW%) xMax%+=20 Calculate position of person pointed to by Chil%, his spouses and descendants. Y% is his top. Return his centre and left and right of everything below him. Calc(Chil%,Y%,Gen%, XLT%, XRT%) DS%,Done%,I%,FO%,P%,SN%,W%,X1%,XF%,XR%,XLF%,XRF%,OxMax%(),N$ OxMax%(MaxGen%) Val(Chil%): P%=0 1,"PROCCalc" DS%=ObVal%!(Chil%!ObSubs%) DS%!DSy%>Y% X%=xMax%(Gen%):XLT%=X%:XRT%=X%: DS%!DSy%=Y%-LineHeight% ShowName(P%,Gen%=0) Free(DS%!DSName%):DS%!DSName%= String(N$) Width(N$) ShowDates% Max(W%, Width( Dates(P%))):Y%-=LineHeight% #Y%-=4*LineHeight%: W% W%+=Gap% Min(yMin%,Y%) FI%=0:FO%=0 : 1st of >1 spouses is #1 else no # GetSub(P%,FamsTg%,FO%) GetSub(P%,FamsTg%,FO%) I%=1 DS%!DSSpNum%=I% OxMax%()=xMax%():Done%= If no families place against border. @ X%=OxMax%(Gen%):XR%=X%+W% : P%'s borders if no families XLT%=X%:XRT%=XR% = X%+=W% 2 : P%'s centre if no families X1%=0:XF%=X1%:FO%=0 GetSub(P%,FamsTg%,FO%) 4 CalcFam(P%, Val(FO%),Y%,Gen%,XF%,XLF%,XRF%) ' X1%=0 X1%=XF%: Min(XLT%,XLF%) Max(XRT%,XRF%) X1% 1 XF%=(X1%+XF%) 2:Done%=XF%>=X% Done% Done% < If families to right of P%, centre over families X%=XF%:XR%=XF%+W% H If P% to right of families, shift descendants' borders right " xMax%()=OxMax%():X%-=XF% - I%=Gen% MaxGen%:xMax%(I%)+=X%: Done% Max(xMax%(Gen%),XR%) 1DS%!DSx%=X%:DS%!DSxmin%=XLT%:DS%!DSxmax%=XRT% Calculate positions of Top%'s spouse in Fam% and their kids. Return centre of spouse and left and right of spouse/kids. Y% is top of kids. CalcFam(Top%,Fam%,Y%,Gen%, XLT%, XRT%) Spouse%,CO%,Done%,DS%,I%,N$,W%,X1%,XC%,XR%,XLF%,XRF%,OxMax%() OxMax%(MaxGen%) Spouse%=0 GetSub(Fam%,HusbTg%,Spouse%) Val(Spouse%)=Top% Spouse%=0:z= GetSub(Fam%,WifeTg%,Spouse%) Spouse% N$= Name( Val(Spouse%)) Width(N$)+Gap% OxMax%()=xMax%():Done%= 3 X%=xMax%(Gen%):XR%=X%+W% : Wife's borders XLT%=X%:XRT%=XR% < X%+=W% 2 : Centre of wife if no kids X1%=0:CO%=0 Gen%=X% Done% Done% < If kids to right of wife - centre wife over kids X%=XC%:XR%=X%+W% D Wife to right of kids - shift descendants' borders right " xMax%()=OxMax%():X%-=XC% / I%=Gen%+1 MaxGen%:xMax%(I%)+=X%: : No kids Spouse%=0 X%=0 Done% xMax%(Gen%)=XR% Spouse%=0 DDS%=ObVal%!(Spouse%!ObSubs%):DS%!DSx%=X%:DS%!DSy%=Y%+LineHeight% Free(DS%!DSName%):DS%!DSName%= String(N$) ShowName(P%,ShowFam%) I%,J%,F$,G$,N$ P%=0 1,"FNShowName" Name(P%) ShowFamilyName% ShowFam% Hide family name if same as father's and father visible " F$= FamName(N$): F$="" Father(P%): I%=0 $'G$= FamName( Name(I%)): G$="" G$<>F$ &'J%=0: I%=J%:J%= N$,F$,I%+1): J%=0 '%J%=I%+ (F$): N$,J%,1)="/" J%+=1 N$,I%-2)+ N$,J%) Width(S$) UseFont% =CharW%* "Font_StringWidth",,S$,Infinity%,Infinity%,-1,Infinity% mPtPerOS% ========================= Display tree =========================== Display tree starting at person pointed to by TopChil% at pre- calculated work coords. xMin%..yMax% is visible work rectangle. Globals XW%,YW% contain the screen coords of the work area origin which is added to work coords for plotting. These routines are used for screen display (OutputTo%=OutScreen%, printing (OutputTo%=OutPrint%), and for making DrawFiles (OutputTo%=OutDraw%). Display(xMin%,yMin%,xMax%,yMax%,OutputTo%) OutputTo%=OutPrint% Colour(Black%) DisplayIndi(TopChil%,-LineHeight%,xMin%,yMin%-LineHeight%,xMax%,yMax%) DisplayIndi(Chil%,Y%,xMin%,yMin%,xMax%,yMax%) CO%,DS%,F%,FO%,H%,P%,S%,SL%,SN%,SP%,SR%,XP%,YP%,X1%,XM%,N$ Val(Chil%) ACDS%=ObVal%!(Chil%!ObSubs%) : First subobj is display struct DS%!DSxmin%>=xMax% DS%!DSxmax%<=xMin% XP%=DS%!DSx%:YP%=DS%!DSy% YP%<=yMin% YP%<>Y% G2Y%-=4*LineHeight%: ShowDates% Y%-=LineHeight% H8SN%=DS%!DSSpNum% : 1 => Number spouses OutputTo%<>OutPrint% SexColour(P%) Centre($(DS%!DSName%),XP%,YP%, OutputTo%<>OutPrint% Colour(Black%):FontCol%=Black% ShowDates% Centre( Dates(P%),XP%,YP%-LineHeight%, H%=LineHeight% 2-4:FO%=0 GetSub(P%,FamsTg%,FO%) O& F%= Val(FO%):X1%=Infinity%:CO%=0 GetSub(F%,ChilTg%,CO%) GetPos(CO%,XP%,YP%) R: YP%+=YW%+LineHeight% : YP% now screen coords OutputTo%=OutDraw% T7 dw_line(XW%+XP%,YP%,XW%+XP%,YP%-H%,FontCol%) U V: XW%+XP%,YP%: BY 0,-H% : Vertical above child W X1%=Infinity% X1%=XP% Y4 DisplayIndi(CO%,Y%,xMin%,yMin%,xMax%,yMax%) X1%<>Infinity% \C XM%=(X1%+XP%) 2 : Between first and last OutputTo%=OutDraw% ^4 dw_line(XW%+XM%,YP%,XW%+XM%,YP%+H%,Fore%) _1 dw_line(XW%+X1%,YP%,XW%+XP%,YP%,Fore%) ` X1%+=XW%:XP%+=XW% b" OutputTo%=OutScreen% c# Avoid 16-bit overflow d; X1%<-10000 X1%=-10000 X1%>10000 X1%=10000 e; XP%<-10000 XP%=-10000 XP%>10000 XP%=10000 g: XW%+XM%,YP%: BY 0,H% : Vertical below spouse h2 X1%,YP%,XP%,YP% : Horizontal i Find other parent in P%'s FAMS F% SR%=0 GetSub(F%,HusbTg%,SR%) SP%= Val(SR%) o> SP%=P% SR%=0: GetSub(F%,WifeTg%,SR%) SP%= Val(SR%) S%= SR% s9 SL%=0: Spouses(SP%,SL%)=0 1,"PROCDisplayIndi" t- DS%=ObVal%!(SR%!ObSubs%):XM%=DS%!DSx% u. S%= Father(SP%): S%=0 S%= Mother(SP%) v. OutputTo%<>OutPrint% SexColour(SP%) w7 Centre($(DS%!DSName%),XM%,Y%+2*LineHeight%,S%) x> OutputTo%<>OutPrint% Colour(Black%):FontCol%=Black% y: S%= Spouses(SP%,SL%) : SP% has other spouses? {$ N$="=": SN% N$+= (SN%):SN%+=1 Centre(N$,XM%,Y%+3*LineHeight%,S%) Centre(S$,X%,Y%,Plus%) W%:W%= Width(S$)>>1 X%+=XW%-W%:Y%+=YW% UseFont% OutputTo%=OutDraw% Plus% S$+=" + dw_text(X%,Y%,PtSize%,FontCol%,S$) Screen or printer # Avoid PLOT coord overflow 3 X%<-10000 X%=-10000 X%>10000 X%=10000 - Plus% S$+= (11)+ (16)+ (0)+"+" = "Font_Paint",Font%,S$,&310,X%,Y%-LineHeight% X%,Y%+12: Plus% BY 0,10: Set the foreground colour and font for system font, lines and outline fonts. Fore% is &BBGGRR00. Colour(Fore%) Set GCOL for system font and lines "ColourTrans_SetGCOL",Fore%,,,0 "ColourTrans_SetGCOL",White%,,,1<<7 : Background Set font and font colours in case using outline fonts "Font_SetFont",Font% "ColourTrans_SetFontColours",Font%,White%,Fore%,14 SexColour(P%) Sex(P%) "M" : Colour(Blue%):FontCol%=Blue% "F" : Colour(Red%):FontCol%=Red% Colour(Green%):FontCol%=Green% A%,B%) B%A% A%=B% ============================= WIMP =============================== Load a template and create the window. The block is loaded at b%+4 so it can be used for Wimp_OpenWindow. GetTem($mess%) "Wimp_LoadTemplate",,b%+4,ind%,indend%,-1,mess% ,,ind% b%!(4+64)=Sprites% :REM User sprite area "Wimp_CreateWindow",,b%+4 Open window on top Open(!b%) "Wimp_GetWindowState",,b% %b%!28=-1: "Wimp_OpenWindow",,b% Close(!b%) "Wimp_CloseWindow",,b% Set work area extent and visible area. Top left is work origin. Bring window to front if Front%. Extent(WH%,Width%,Height%,Front%) Depth% Front% Depth%=-1 !b%=WH%: "Wimp_GetWindowState",,b%:Depth%=b%!28 Close(WH%) : Force redraw ;b%!0=0:b%!4=-Height% 7:b%!8=(Width%+7) 7:b%!12=0 "Wimp_SetExtent",WH%,b% Resize visible area bottom right to work area =!b%=WH%:b%!12=b%!4+Width%:b%!8=b%!16-Height%:b%!28=Depth% "Wimp_OpenWindow",,b% Redraw icon given window and icon handles and selection state SelIcon(b%!0,b%!4,On%) %b%!8=(1<<21) On%<>0:b%!12=1<<21 "Wimp_SetIconState",,b% Is icon selected? SelIcon(b%!0,b%!4) "Wimp_GetIconState",,b% =(b%!24 1<<21)<>0 Return the address of the indirected text of WH's icon IH. Also the address of an indirected sprite. IcTxt(b%!0,b%!4) : WH, IH "Wimp_GetIconState",,b% =b%!28 Caret(WH%,IH%,End%) End% L%= IcTxt(WH%,IH%)) L%=0 "Wimp_SetCaretPosition",WH%,IH%,,,-1,L% SelIcon(WH%,IH%, ) : Redraw icon Key(WH%,IH%,Key%) Key% Print%: Print F1% : Complete(WH%,IH%) F3% : MouseMenu(SaveWH%) : F3 Save F5% : MouseMenu(GotoWH%) : F5 Goto CtrlC%: EditChild(Person%) : ^C adds child CtrlE%: EditPerson(Person%) : ^E edits current CtrlS%: WH%=EditWH% Edit(0,Key%) : ^S toggles sex Return passed as key event. Note any K command in the validation string prevents CR being passed. Kt only passes it for the last icon. CR%,UpArrow%,DownArrow%: WH%>0 Buttons(0,0,Key%,WH%,IH%) Tab% : Key(WH%,IH%,DownArrow%) ShfTab%: Key(WH%,IH%,UpArrow%) CtrlQ%: "Wimp_ProcessKey",Key% Mouse event @ X,Y or key press Buttons(X%,Y%,But%,WH%,IH%) But%=2 WH%<0 IH%<0 OpenMenu(X%,Y%,WH%): WH% -2 : Icon bar Person% Open(NoteWH%) Open(MainWH%) CompWH%: Comp(Y%) EditWH%: Edit(IH%,But%) GotoWH%,MarryWH% IH%=GoIcOK%,But%=CR% ( P%= Find($ IcTxt(WH%,GoIcName%)) : WH%=GotoWH% Goto(P%) Marry(MenuPerson%,P%) IH%=GoIcCur% - $ IcTxt(WH%,GoIcName%)= Name(Person%) Caret(WH%,GoIcName%, IH%=GoIcCan%:But%=4 MainWH% P%= Near(X%,Y%): P%=0 But%=1 EditPerson(P%) Goto(P%) ModsWH% IH% MoIcDisc% Modified%= ToDo$ ".Q": ".R": Reset Load(ToDo$, & MoIcSave%: MouseMenu(SaveWH%): But%=4 NoteWH%: EditNotes SaveWH%,RepoWH%,DrawWH%: Save(WH%,IH%,But%) ObEdWH%: ObEdClick(Y%) WH% GotoWH%,InfoWH%,MarryWH%,ModsWH% But%<>1 Close(WH%): "Wimp_CreateMenu",,-1:Menu%=0 Open a filer window on the directory of TreeFile$ if it includes one and the ADJUST botton is pressed. OpenDir I%,P%,D$ "Wimp_GetPointerInfo",,b%: b%!8<>1 I%=1:P%=0 TreeFile$,".",I%+1): I% P%=I% I%=0 P%=0 TreeFile$,P%-1) ?2b%!20=0:b%!24=0: Send(OpenDir,D$,17,b%,0,0,28) GetVar(Var$) Len% "XOS_ReadVarVal",Var$,b%,blen% ,,Len% b%?Len%=CR%:=$b% Return the zero-terminated string at S% as a Basic string GetZStr(S%) P%:P%=S% ?P%:P%+=1: $P%="" ========================= Initialisation ========================= D("") S4Infinity%=999999 : Well off screen TFCharW%=16:CharH%=32 : System character size in OS units UGMinW%=600 : Min width of main window work area V6Hash%=0 : No hash table yet Modified%= X5ModifiedShown%= Modified% : Force title redraw Y7LF%=10:CR%=13:CtrlC%=3:CtrlE%=5:CtrlQ%=17:CtrlS%=19 Z%Space%= " ":LPar%= "(":LBra%= [*Print%=&180:F1%=&181:F3%=&183:F5%=&185 \+Tab%=&18A:DownArrow%=&18E:UpArrow%=&18F ShfTab%=&19A ^ CR4$= CR%+ CR%+ CR%+ Palette entries &BBGGRR00 a;Black%=0:White%=&FFFFFF00 : foreground, background b3Red%=&0000FF00:Green%=&00FF0000:Blue%=&FF000000 WIMP Messages Quit=0 f@DataSave=1:DataSaveAck=2:DataLoad=3:DataLoadAck=4:DataOpen=5 g:PreQuit=8:OpenDir=&400:HelpRequest=&502:HelpReply=&503 MenusDeleted=&400C9 External edit messages k2EditRq=&45D80:EditAck=&45D81:EditReturn=&45D82 l(EditAbort=&45D83:EditDataSave=&45D84 ExtEdJob%=0 blen%=2048:messlen%=400 b% blen%: ind% 2600,indend% -1,mess% messlen% q9$b%="TASK": "Wimp_Initialise",200,!b%,Task$ ,Task% Files and filetypes "OS_FSControl",31,"GEDCOM" ,,TreeType% "OS_FSControl",31,"Text" ,,TextType% "OS_FSControl",31,"DrawFile" ,,DrawType% x"ReportType%=TextType% &10000 SaveType%=0 TreeLeaf$="Tree" NoteLeaf$="Notes" |4NoteFile$= GetVar("Wimp$ScrapDir")+"."+NoteLeaf$ ReportLeaf$="Report" DrawLeaf$="DrawFile" Scrap$="" #OptFile$=".Choices" LoadOpts Load sprites into user sprite area used by FNGetTem LOCAL SpriteFile$ SpriteFile$=".Sprites" Len%=FNFileLen(SpriteFile$)+4 :REM Add room for sprite area size. DIM Sprites% Len% Sprites%!0=Len%:Sprites%!8=16 SYS "OS_SpriteOp",256+9,Sprites% :REM Init area. SYS "OS_SpriteOp",256+10,Sprites%,SpriteFile$ :REM Load. Create windows "Wimp_OpenTemplate",,".Templates" CompWH%= GetTem("Comp") A$(b%+76)="GEDCOM Edit": "Wimp_CreateWindow",,b%+4 ObEdWH% EditWH%= GetTem("Edit") CEdIcName%=0:EdIcBorn%=1:EdIcDied%=2:EdIcFather%=3:EdIcMother%=4 2EdIcMale%=5:EdIcFemale%=6:EdIcCan%=7:EdIcOK%=8 GGotoWH%= GetTem("Goto"):GoIcName%=0:GoIcCan%=1:GoIcCur%=2:GoIcOK%=3 @$(b%+4+72)= MT("MT"): "Wimp_CreateWindow",,b%+4 MarryWH% InfoWH%= GetTem("Info") $b%!(4+88+20)=Task$ $b%!(4+88+32+20)=Purpose$ $b%!(4+88+64+20)=Author$ $b%!(4+88+96+20)=Version$ MainWH%= GetTem("Main") >ModsWH%= GetTem("Mods"):MoIcDisc%=0:MoIcCan%=1:MoIcSave%=2 ,NoteWH%= GetTem("Note"):NoteTitle%=b%!76 SaveWH%= GetTem("Save") 2SaIcFile%=0:SaIcSprite%=1:SaIcOK%=2:SaIcCan%=3 RepoWH%= GetTem("Repo") DrawWH%= GetTem("Draw") "Wimp_CloseTemplate" Open(MainWH%) BarIcText% 10,BarIcValid% 20 b%!0=-1:b%!4=0:b%!8=0 %b%!12=68:b%!16=68:b%!20=&1700310B /b%!24=BarIcText%:b%!28=BarIcValid%:b%!32=10 $BarIcText%="" $BarIcValid%="S!"+Task$+ "Wimp_CreateIcon",,b% BarIc% Comp%(MaxComp%) Database structures 5ObTag%=0:ObVal%=4:ObSubs%=8:ObNext%=12:ObSize%=16 IdNext%=0:IdObj%=4:IdName%=8 IObRef%=1 : Flag set in ObVal if it's an obj ref J : (but not a display structure pointer) Display structure xMax%(MaxGen%) : Current right edge of tree at each level 4DSx%=0:DSy%=4 : Person's centre >DSxmin%=8:DSxmax%=12 : Person+descendants extent 6DSSpNum%=16 : Spouses numbered? >DSName%=20 : Pointer to displayed name DSSize%=24 Output types 'OutScreen%=1:OutPrint%=2:OutDraw%=3 ===================== Menus & dialog boxes ======================= Create menus CrMenu (DivorceM%= InitMenu("Di",MaxSpouse%) OPersM%= Menu("Pe","Ed ^E:EditWH%,Mr:MarryWH%,Di:DivorceM%,Ci...^C,Ol,Rm") 0PersNameLen%=128: PersNameBuf% PersNameLen% hMainM%= Menu("Fa","Pe:PersM%#IPersNameBuf%:PersNameLen%,GE:,Go F5:GotoWH%,Sa F3:SaveWH%,Qu ^Q") Font list is set by PROCShowOpts /FontSizeLen%=10: FontSizeBuf% FontSizeLen% -1 N: N%=DivorceM%!(28+24*Choice2%+12) : Name in menu O+ S%= Look($N%): S%=0 1,"Spouse" P" Divorce(MenuPerson%,S%) Q EditChild(MenuPerson%) Older Kill(MenuPerson%): Person%=MenuPerson% Goto(0) 101: ObjEdit 102: MouseMenu(GotoWH%) But%=1 Menu%=BarM% ShowOpts : Update ticks on choices "Wimp_CreateMenu",,Menu%,MenuX%,MenuY% Menu%=0 E$ = ",,.." = ":[[#]]" No => -1 Flags = I: => indirected (must be last flag) W => writable Menu(Title$,E$) I%,M%,N%,Width% i-I%=1:N%=0: N%+=1:I%= E$,",",I%+1): I%=0 InitMenu(Title$,N%) I%=M%+4:Width%=8 m I%+=24:E$= MenuItem(I%,E$) I%!8 1<<8 N%= ($(I%!12)) ($(I%+12)) Max(Width%,N%) E$="" q-!I%=!I% 1<<7 : Last item M%!16=(Width%+1)*CharW% InitMenu(Title$,Entries%) M% 28+24*Entries% MT(Title$) y#M%?12=7:M%?13=2:M%?14=7:M%?15=0 M%!16=160:M%!20=44:M%!24=0 MenuItem(I%,E$) Rest$,S$,P%,S% this-entry "," other-entries E$+",",",",S%):Rest$= E$,S%+1):E$= E$,S%-1) String-to-display ":" submenu E$+":",":") E$,S%-1) Translate 2 char message token at start of string S$>"" S$= S$,2))+ S$,3) E$,S%+1): E$="" E$="-1" "!I%=0:I%!4= (E$):I%!8=&7000021 sub-val "#" options P%=0:E$= E$+"#","#")+1) E$>"" : Optional flags E$,1) "I" : Indirect I%!8=I%!8 1<<8 - S%= E$,":") : After pointer ) P%= E$,2,S%-2)) : Buf pointer I%!12=P%:I%!16=-1 % I%!20= E$,S%+1)) : Buf len 2 E$="" : no more flags "W":!I%=!I% 1<<2 : Writeable E$= E$,2) P%=0 : P%=I%+12:S%= (S$)+1 : Long string => indirect S%>12 P% S% 3 I%!8=I%!8 1<<8:I%!12=P%:I%!16=-1:I%!20=S% $P%=S$ =Rest$ (Un)Shade menu entry Shade(Menu%,Entry%,Shade%) B%:B%=1<<22 /Menu%+=28+24*Entry%+8 : Menu flags &!Menu%=!Menu% Shade% (Un)Tick menu entry SelEntry(Menu%,Entry%,Tick%) Menu%+=28+24*Entry% (!Menu%=!Menu% (Tick%<>0) ============================= Edit =============================== Goto(P%) Person%=P% GForce%=2 : Scroll window to centre new person Force note window and title P% $NoteTitle%= Name(P%): OpenNotes Close(NoteWH%) Create a level 0 NOTE object giving the current person's name SetPerson Mod%,N%,O%,P% Kill any old person note P%=Root%+ObSubs% O%=!P%:N%=O%+ObNext% O%!ObTag%=NoteTg% O%!ObVal% ' $(O%!ObVal%),6)="Person" Free(O%!ObVal%) !P%=!N%:N%=P% P%=N% @Mod%=Modified% : Preserve modification state Person% SetStr(Root%,NoteTg%,"Person "+ Name(Person%), Modified%=Mod% Return the person near screen X%,Y%. Try the dummy CHIL at the top of the tree first, then each member of each FAM. Near(X%,Y%) B%,D%,DS%,BD%,F%,S%,R% >R%=1.5*LineHeight% : Distance from name centre ,!b%=MainWH%: "Wimp_GetWindowState",,b% @X%-=(b%!4-b%!20):Y%-=(b%!16-b%!24) : convert to work coords B%=0:BD%=Infinity% F%=0:S%=TopChil% S%>1 S%!ObTag% HusbTg%,WifeTg%,ChilTg% DS%=ObVal%!(S%!ObSubs%) ( D%= (X%-DS%!DSx%)+ (Y%-DS%!DSy%) IF D%EdIcOK% Edited Close(EditWH%) "Wimp_CreateMenu",,-1:Menu%=0 Person% Force%=1 Goto(MenuPerson%) Set edited details Edited N$,Sex$ !N$=$ IcTxt(EditWH%,EdIcName%) N$="" MT("NN") MenuPerson% Name(MenuPerson%)<>N$ ! Name changed - reinsert ) SetStr(MenuPerson%,NameTg%,N$, % RemSubObj(Root%,MenuPerson%) Insert(MenuPerson%) MenuPerson%= Find(N$) EventDate(MenuPerson%,BirtTg%,$ IcTxt(EditWH%,EdIcBorn%)) EventDate(MenuPerson%,DeatTg%,$ IcTxt(EditWH%,EdIcDied%)) &BN$=$ IcTxt(EditWH%,EdIcFather%): Father(MenuPerson%, Find(N$)) 'BN$=$ IcTxt(EditWH%,EdIcMother%): Mother(MenuPerson%, Find(N$)) SelIcon(EditWH%,EdIcMale%) :Sex$="M" SelIcon(EditWH%,EdIcFemale%):Sex$="F" :Sex$="" Sex(MenuPerson%,Sex$) Set the DATE of P%'s Tag% event to Val$ EventDate(P%,Tag%,Val$) P%=0 1,"PROCEventDate" Val$>"" SetSub(P%,Tag%,0, GetSub(P%,Tag%,E%) SetStr(E%,DateTg%,Val$, Father(P%)= Parent(P%,HusbTg%) Mother(P%)= Parent(P%,WifeTg%) Get the family pointed to by P%'s FAMC sub-object. Return the person pointed to by its Tag% sub-object or 0 if none. Parent(P%,Tag%) P%=0 Tag%=0 1,"FNParent" B2P%= GetVal(P%,FamcTg%): GetVal(P%,Tag%) Return P%'s father, mother, self or 0. Fore(P%) P%=0 Father(P%): Mother(P%): Birth(P%)= Date(P%,BirtTg%) Death(P%)= Date(P%,DeatTg%) Return the value string for the DATE sub-object of P%'s event sub-object with Tag% Date(P%,Tag%) P%=0 1,"FNDate" X4E%=0: GetSub(P%,Tag%,E%) GetStr(E%,DateTg%) Sex(P%,S$) P%=0 1,"PROCSex" SetStr(P%,SexTg%,S$, Sex(P%)= GetStr(P%,SexTg%) MaleFemale( Him%, Her%) Sex(Him%)="F" Sex(Her%)="M" Him%,Her% Him% Sex(Him%,"M") Her% Sex(Her%,"F") Swap MenuPerson% with his earlier sibling Older F%,P%,Old%,C% l#F%= GetVal(MenuPerson%,FamcTg%) Old%=0:P%=F%+ObSubs% C%=!P% C%!ObTag%=ChilTg% r" Val(C%)=MenuPerson% F%=0 tB Old% Old%!ObVal%,C%!ObVal%:Modified%= :Force%=1: Old%=C% w P%=C%+ObNext% Name(MenuPerson%)+" "+ MT("NE") Fill in edit box for a new person whose parent is Dad% (may be female). If he has one spouse assume she is the child's other parent. If the child's father is known initialise his family name. EditChild(Dad%) L%,Mum%,F$ Dad%=0 EditPerson(0): :L%=0:Mum%= Spouses(Dad%,L%): Spouses(Dad%,L%) Mum%=0 MaleFemale(Dad%,Mum%) ;F$="": Dad% F$= FamName( Name(Dad%)): F$>"" F$=" "+F$ IcTxt(EditWH%,EdIcName%)=F$ SelIcon(EditWH%,EdIcMale%, Default male. SelIcon(EditWH%,EdIcFemale%, IcTxt(EditWH%,EdIcFather%)= Name(Dad%) IcTxt(EditWH%,EdIcMother%)= Name(Mum%) IcTxt(EditWH%,EdIcBorn%)="" IcTxt(EditWH%,EdIcDied%)="" Open(EditWH%) Caret(EditWH%,EdIcName%, Caret at start HMenuPerson%=0 : Create new person if edit completed Father(C%,P%) ChkSex(P%,"M","Ml") Parent(C%,P%,HusbTg%) Mother(C%,P%) ChkSex(P%,"F","Fe") Parent(C%,P%,WifeTg%) ChkSex(P%,Gender$,GT$) P%=0 Sex(P%) Gender$ Sex(P%,Gender$) Name(P%)+" "+ MT("IN")+" "+ MT(GT$) Set C%'s Tag% parent to P% Parent(C%,P%,Tag%) Dad%,Mum%,F%,O% C%=0 1,"PROCParent" GetVal(C%,FamcTg%):Dad%=0:Mum%=0 ove C% from current family unless the parent is already there GetVal(F%,Tag%)=P% 7 Dad%= GetVal(F%,HusbTg%):Mum%= GetVal(F%,WifeTg%) RemSub(F%,ChilTg%,C%) ChkFam(F%) C% now an orphan. Set new parent. Tag%=HusbTg% Dad%=P% Mum%=P% Dad%=0 Mum%=0 See if Dad has a family with Mum (either may be 0) Dad% O%=0 GetSub(Dad%,FamsTg%,O%) F%=0 4 F%= Val(O%): GetVal(F%,WifeTg%)<>Mum% F%=0 See if Mum has a family with Dad Mum% F%=0 O%=0 GetSub(Mum%,FamsTg%,O%) F%=0 4 F%= Val(O%): GetVal(F%,HusbTg%)<>Dad% F%=0 F%=0 F%= NewFam(Dad%,Mum%) SetSub(C%,FamcTg%,F% ObRef%, SetSub(F%,ChilTg%,C% ObRef%, ChkFam(F%) Modified%= :Force%=1 ==================== Individuals & families ====================== Look up name N$ and return person if found, else 0 Look(N$) H%,P% Hash(N$):P%=Hash%!H%: Name(P%)=N$ GetSub(Root%,IndiTg%,P%) Name(P%)=N$ Hash%!H%=P%:=P% Find an existing person named N$ or create a new one Find(N$) N$="" Look(N$) P%=0 P%= NewIndi(N$): Insert(P%) : Sort into Root%'s list InitHash 1HashSize%=1<<12:HashMask%=(HashSize%-1) Hash%=0 Hash% HashSize% H%=0 HashSize%-1 4:Hash%!H%=0: Hash($b%) I%,H%:H%=0 I%=0 9:H%+=H%+b%?I%: HashMask% NewIndi(N$) Object(IndiTg%,0) SetStr(P%,NameTg%,N$, N$>"" Hash%! Hash(N$)=P% Modified%= :Force%=1 Every FAM member's first sub-object is a display structure DStruct(P%) D%,O%,S% S%=P%!ObSubs% S%!ObTag%=DispTg% =S%!ObVal% Alloc(DSSize%):D%!DSName%=0 Object(DispTg%,D%) P%!ObSubs%=O%:O%!ObNext%=S% Create a new family with Dad% and Mum%. Link it to them and v.v. NewFam(Dad%,Mum%) Object(FamTg%,0) Tail(Root%)=F% Dad% SetSub(F%,HusbTg%,Dad% ObRef%, SetSub(Dad%,FamsTg%,F% ObRef%, Mum% SetSub(F%,WifeTg%,Mum% ObRef%, SetSub(Mum%,FamsTg%,F% ObRef%, Add O% as an INDI just before the first INDI sub-object of root with a name after O%'s Insert(O%) Position(O%) O%!ObNext%=!P% !P%=O% Position(O%) P%,N$,NO$,F$,FO$ #NO$= Name(O%):FO$= FamName(NO$) P%=Root%+ObSubs% O%=!P% O%!ObTag%=IndiTg% $ N$= Name(O%):F$= FamName(N$) F$>FO$ F$=FO$ N$>NO$ P%=O%+ObNext% If family F% has < 2 members, unlink it & kill it ChkFam(F%) M%,N% F%=0 1,"PROCChkFam" S%=F%!ObSubs%:N%=0 N%<2 S%!ObTag% ChilTg%,HusbTg%,WifeTg%:N%+=1 S%=S%!ObNext% N%<2 Kill(F%) ============================= Notes ============================== Return Person%'s first or next CONT or NOTE sub-object. Call with N%=0 for first. Result also returned in O%. GetNote( O%=N% O%=0 <) O%= GetSub(N%,ContTg%,O%): >&O%= GetSub(Person%,NoteTg%,N%):=O% OpenNotes Lines%,N%,O% Lines%=0:N%=0 GetNote(N%,O%):Lines%+=1: D+!b%=NoteWH%: "Wimp_GetWindowInfo",,b% Extent(NoteWH%,b%!52-b%!44,(Lines%+1)*(CharH%+4), Draw Person's first NOTE object and any CONT sub-objects DrawNote(X%,Y%) N%,O% Person%=0 X%+=8:Y%-=8:N%=0 GetNote(N%,O%) O%!ObVal% X%,Y%: $(O%!ObVal%); Y%-=CharH%+4 Broadcast a request for an external edit of P%'s notes. Should get EditAck reply or EditRq bounce. EditNotes I%,N$ Person%=0 1,"PROCEditNotes" mess%!20=TextType% [@mess%!24=1 : Arbitrary client job handle \6mess%!28=1 : Continue editing? Tidy name for use as job parent Id Name(Person%) N$>"" Alpha(N$) N$= N$,2): I%<= Alpha( N$,I%)) I%+=1 N$,I%-1)+ N$,I%+1) d($(mess%+32)= N$,19)+ Parent ID. Send(EditRq,NoteLeaf$,18,mess%,0,0,52) WriteNotes(F$) : Write notes to a file WriteNotesFile(F%,"") SetFileType(F$,TextType%) WriteNotesFile(F%,Prefix$) O%,N%:N%=0 GetNote(N%,O%) #F%,Prefix$+ Null(O%!ObVal%) Read notes for the current person from a file LoadNotes(F$) F%,P% {)F%= (F$): F%=0 MT("CR")+" "+F$ Person%=0 MT("NP") Delete all Person's existing note sub-objects DelTag(Person%,NoteTg%) Tail(Person%) 7 !P%= Object(NoteTg%, String( #F%)):P%=!P%+ObSubs% 7 !P%= Object(ContTg%, String( #F%)):P%=!P%+ObNext% F$=NoteFile$ F$=Scrap$ DelFile(NoteFile$) : Delete scrap file. OpenNotes Modified%= =========================== Spouses ============================== Return P%'s first spouse if F%=0 else return next spouse. Update F% to P%'s FAMS. Return 0 when no more spouses. Ignore families with unknown spouse. Spouses(P%, H%,W%,FO% P%=0 1,"FNSpouses 1" GetSub(P%,FamsTg%,F%) FO%= Val(F%) H%= GetVal(FO%,HusbTg%) W%= GetVal(FO%,WifeTg%) 1,"FNSpouses 2" Ensure that there is a family with parents Mum% and Dad% Marry(Dad%,Mum%) F%,O%,H%,W% Dad%=0 Mum%=0 MaleFemale(Dad%,Mum%) : Ensure Dad% is male 9O%=0:H%=-1:W%=-1 : Dad already married? GetSub(Dad%,FamsTg%,O%) ? F%= Val(O%):H%= GetVal(F%,HusbTg%):W%= GetVal(F%,WifeTg%) H%=Dad% W%=Mum% F%=0 9 O%=0:H%=-1:W%=-1 : Mum already married? GetSub(Mum%,FamsTg%,O%) A F%= Val(O%):H%= GetVal(F%,HusbTg%):W%= GetVal(F%,WifeTg%) H%=Dad% W%=Mum% Add new spouse to arbitrary existing single-parent family if any H%=0: SetSub(F%,HusbTg%,Dad% ObRef%, SetSub(Dad%,FamsTg%,F% ObRef%, W%=0: SetSub(F%,WifeTg%,Mum% ObRef%, SetSub(Mum%,FamsTg%,F% ObRef%, NewFam(Dad%,Mum%) Modified%= :Force%=1 Remove mother from family in which Dad% and Mum% are parents if neither is null Divorce(Dad%,Mum%) F%,O% Dad%=0 Mum%=0 MaleFemale(Dad%,Mum%) GetSub(Dad%,FamsTg%,O%) F%= Val(O%) GetVal(F%,WifeTg%)=Mum% RemSub(F%,WifeTg%,Mum%) RemSub(Mum%,FamsTg%,F%) ChkFam(F%) Modified%= :Force%=1 Name(Dad%)+" "+ MT("NM")+" "+ Name(Mum%) OppSex(P%) Sex(P%) "M":="F" "F":="M" ======================== Name completion ========================= Try to complete the name in an icon. Set WHComp% and IHComp% to the icon we are completing. Complete(WH%,IH%) A%,ReqSex$:ReqSex$="" WH% EditWH% IH% EdIcFather%:ReqSex$="M" EdIcMother%:ReqSex$="F" EdIcName% Only for mother, father, name. MarryWH%:ReqSex$= OppSex(MenuPerson%) GotoWH% IcTxt(WH%,IH%) Complete($A%,ReqSex$) Caret(WH%,IH%, WHComp%=WH%:IHComp%=IH% Return longest unambiguous completion of N$ with given sex. If > 1 match, open the pick window else close it. Complete(N$,ReqSex$) Len%,P%,Prefix$,PN$,LowN$ LowN$= Lower(N$) #NComp%=0:Prefix$="*":Len%= GetSub(Root%,IndiTg%,P%) ReqSex$="" Sex(P%)=ReqSex$ PN$= Name(P%) $ Lower( PN$,Len%))=LowN$ 7 NComp%<=MaxComp% Comp%(NComp%)=P%:NComp%+=1 < Prefix$= Common(Prefix$,PN$) : Max shared prefix. NComp%=0 NComp%>1 OpenComp Close(CompWH%) Prefix$="" Prefix$="*" =Prefix$ Return longest common prefix Common(P$,N$) P$="*" Lower(P$) Lower(N$) +L%=1: P$,L%)= Lower( N$,L%)):L%+=1: N$,L%-1) OpenComp I%,M%:M%=0 I%=0 NComp%-1 Max(M%, Name(Comp%(I%)))) !I%=NComp%: I%>MaxComp% I%+=1 Extent(CompWH%,(M%+2)*CharW%,I%*CharH%+16, DrawComp(XW%,YW%) I%=0 NComp%-1 XW%+8,YW%-8-CharH%*I%: Name(Comp%(I%)) NComp%>MaxComp% XW%+8,YW%-8-CharH%*NComp%: "..." Click in completion list. Set text in icon being completed. Comp(Y%) I%,YW%,IH%,WH% &,!b%=CompWH%: "Wimp_GetWindowState",,b% YW%=b%!16-b%!24 I%=(YW%-8-Y%) CharH% I%>=NComp% Set text in icon. Ensure window open and redraw icon IcTxt(WHComp%,IHComp%)= Name(Comp%(I%)) Close(CompWH%) Open(WHComp%): Caret(WHComp%,IHComp%, =========================== Messages ============================= Received a type 17 or 18 message. The message is at b%. Receive(Size%,SrcTask%,HisRef%,Action%) P%,Type%,F$ Ignore own messages. SrcTask%=Task% PROCD("Rec &"+STR$~Action%) Action% Quit:Modified%= PreQuit Modified% NotOK( MT("UC")) >1 b%!12=HisRef%: "Wimp_SendMessage",19,b% DataSave,EditDataSave He has data for us. Tell him where to stick it. Notes might be considered 'safe' but that confuses !Zap so say they're unsafe. b%!36=-1 Send(DataSaveAck,Scrap$,17,b%,SrcTask%,HisRef%,44) DataSaveAck : He says where to save data "Wimp_CreateMenu",,-1:Menu%=0 F$= GetZStr(b%+44) SaveType(F$,b%!36>=0) Tell him to load data from file. Rest of mess set up from our DataSave. This should be sent as type 18 (recorded) but StrongEd doesn't seem to reply soon enough. Send(DataLoad,F$,17,mess%,SrcTask%,HisRef%,44) DataLoad : He wants us to load a file Type%=b%!40 F$= GetZStr(b%+44) "Wimp_GetPointerInfo",,b% Load(F$,b%!12=-2) : Reset for drag to icon bar Tell him we got it. StrongED is logical but non-standard because it looks at b%!36 from DataLoadAck instead of DataSaveAck. T: b%!36=-1 : For naughty StrongED. Send(DataLoadAck,F$,17,b%,SrcTask%,HisRef%,44) F$=Scrap$ DelFile(Scrap$) Type%=TextType% ExtEdAbort DataOpen : Load a Filer_Run file b%!40<>TreeType% F$= GetZStr(b%+44) Acknowledge DataOpen now in case load fails \E b%!36=-1 : For naughty StrongED (see above) Send(DataLoadAck,F$,17,b%,SrcTask%,HisRef%,44) Load(F$, ) : Reset for DataOpen DataLoadAck : He has loaded & deleted data EditAck : External edit request accepted ExtEdJob%=b%!24 b/ mess%!20=ExtEdJob% : Job handle c8 mess%!36=0 : Estimated data size mess%!40=TextType% Send(EditDataSave,NoteLeaf$,18,mess%,SrcTask%,HisRef%,44) f< SaveType%=TextType% : ember what we're saving HelpRequest F$= Help(b%!32,b%!36) F$>"" Send(HelpReply,F$,17,b%,SrcTask%,HisRef%,20) MenusDeleted Menu%=0 Received a type 19 (acknowledge) message (in b%). If it appears to come from this task then it is an unanswered type 18 (recorded). RcvAck(Size%,SrcTask%,Action%) P%,Type%,F$ SrcTask%<>Task% It's one of mine Action% EditRq : Unanswered External edit request WriteNotes(NoteFile$) "Filer_Run "+NoteFile$ : Hope an editor will catch it OTHERWISE PROCD("Ack "+STR$~Action%) Send a message containing a string Send(Action%,String$,N%,Buf%,Dest%,Ref%,Offset%) Buf%!12=Ref% Buf%!16=Action% MessStr(Buf%,Offset%,String$) "Wimp_SendMessage",N%,Buf%,Dest% Insert String$ at Offset% in message in Buf%. Set message length. MessStr(Buf%,Offset%,String$) $(Buf%+Offset%)=String$+ &!Buf%=(Offset%+4+ (String$)) Close any external edit job ExtEdAbort ExtEdJob%=0 +mess%!12=0 : My ref mess%!16=EditAbort -mess%!20=0 : Reserved mess%!24=ExtEdJob% mess%!0=28 "Wimp_SendMessage",17,mess%,SrcTask% =ExtEdJob%=0 : No current external edit Help(WH%,IH%) MHelp(WH%,IH%) T$>"" T$= MT(T$) MHelp(WH%,IH%) WH% -2:="H01" MainWH%:="H02" NoteWH%:="H03" CompWH%:="H04" InfoWH%:="H05" EditWH% IH% EdIcName%:="H06" EdIcBorn%:="H07" EdIcDied%:="H08" EdIcFather%:="H09" EdIcMother%:="H10" EdIcMale%:="H11" EdIcFemale%:="H12" EdIcCan%:="H13" EdIcOK%:="H14" GotoWH% IH% GoIcName%:="H15" GoIcCan%:="H16" GoIcCur%:="H25" GoIcOK%:="H17" MarryWH% IH% GoIcName%:="H18" GoIcCan%:="H19" GoIcCur%:="H25" GoIcOK%:="H20" ModsWH% IH% MoIcDisc%:="H29" MoIcCan%:="H30" MoIcSave%:="H31" RepoWH% IH% SaIcFile%:="H28" SaIcSprite%:="H26" SaIcOK%:="H27" SaIcCan%:="H24" SaveWH% IH% SaIcFile%:="H21" SaIcSprite%:="H22" SaIcOK%:="H23" SaIcCan%:="H24" DrawWH% IH% SaIcFile%:="H32" SaIcSprite%:="H33" SaIcOK%:="H34" SaIcCan%:="H24" ============================= Load =============================== Check the command line for file to load (and print) I%,PrintIt% "OS_GetEnv" $b%,"-quit") I%=0 6I%=b%+I%+5: ?I%=Space% I%+=1: Find prog name ?I%>Space% I%+=1: : Skip prog name ?I%=Space% I%+=1: : Find start of arg PrintIt%= $I%,6)="-print" PrintIt% 4 I%+=6: ?I%=Space% I%+=1: : After -print ?I%<=Space% Load($I%, PrintIt% Print Load(F$,Reset%) F%,T% "OS_File",17,F$ F%,,T%:T%=T%>>8 &FFF F%<>1 MT("NF")+": '"+F$+"'" T%=TextType% LoadNotes(F$): Reset% Mods(F$) T%<>TreeType% NotOK( MT("UF")) MT("CR")+" '"+F$+"'" (F$): F%=0 -1,"dummy" LoadError(F%,F$) Reset% Reset Reset%=Root%!ObSubs%=0 GForce%=2 : Main win to be redrawn & recentred "Hourglass_On" Escape( LoadGed(F%,Reset%) Escape( "Hourglass_Off" Reset% SetFile(F$) Modified%= Goto(Person%) : Set current person LoadError(F%,F$) Escape( Reset MT("BF")+": '"+F$+"' ("+ $+")" Escape(On%) "OS_Byte",229,On%=0 ============================= Save =============================== Save, Draw or Report chosen in the menu or dbox event Save(WH%,IH%,But%) IB%,X0%,Y0%,P%,LP%,F$ IcTxt(WH%,SaIcFile%):F$=$P%:LP%=P% ?P%>31 ?P%= "." LP%=P%+1 P%+=1 :$P%="" ember what we're saving WH%=SaveWH% SaveType%=TreeType% WH%=RepoWH% SaveType%=ReportType% SaveType%=DrawType% IH%=SaIcFile% But%=CR% IH%=SaIcOK% IH% SaIcCan%: Close(WH%): "Wimp_CreateMenu",,-1:Menu%=0 SaIcSprite%: But%>=16 SaveLeaf$=$LP%: StartDrag(WH%) SaIcOK% F$=Scrap$ F$,".") SaveType(F$, MouseMenu(WH%) Start dragging file sprite StartDrag(WH%) 5'!b%=WH%: "Wimp_GetWindowInfo",,b% 6;IB%=b%+4+88+32*SaIcSprite% : File sprite icon block 70X0%=b%!4-b%!20:Y0%=b%!16-b%!24: Work origin 8.b%!4=5 : Fixed box 9:b%!8=X0%+!IB%:b%!12=Y0%+IB%!4 : Screen coords of icon b%!16=X0%+IB%!8 b%!20=Y0%+IB%!12 <+b%!24=0:b%!28=0 : Limits =#b%!32=Infinity%:b%!36=Infinity% "Wimp_DragBox",,b% Drag for save done. Send DataSave msg. DragDone "Wimp_GetPointerInfo",,b% E+mess%!12=0 : My ref F?mess%!16=DataSave : I've got some data for you G:mess%!20=b%!12:mess%!24=b%!16 : Window & icon handles H(mess%!28=!b%:mess%!32=b%!4 : I.mess%!36=0 : File size J.mess%!40=SaveType% : File type MessStr(mess%,44,SaveLeaf$) "Wimp_SendMessage",18,mess%,b%!12,b%!16 Call the right routine to write the curent filetype SaveType(F$,Safe%) SaveType% TreeType% : SaveAs(F$,Safe%) TextType% : WriteNotes(F$) ReportType%: Report(F$) DrawType% : WriteDraw(F$) : 1,"PROCSaveType" "Wimp_CreateMenu",,-1:Menu%=0 Save data to a temporary file in case write fails then rename as F$ SaveAs(F$,Safe%) F%,Temp$:Temp$=F$ SetPerson : Note current person SetHeadTrlr F$<>Scrap$ Temp$,1)="=" MT("CC")+" ("+ $+")" (Temp$) #F%: MT("SF")+" ("+ $+")" "Hourglass_On" Escape( SaveSubs(F%,Root%,0) Escape( "Hourglass_Off" Temp$<>F$ MT("CN")+" '"+F$+"' ("+ $+")" DelFile(F$) : Remove old F$ "OS_FSControl",25,Temp$,F$ : Rename SetFileType(F$,TreeType%) Safe% SetFile(F$) Set up HEAD and TRLR objects, preserving modification SetHeadTrlr H%,Mod%,S% Mod%=Modified%:H%=0 GetSub(Root%,HeadTg%,H%)=0 H%= Object(HeadTg%,0) H%!ObNext%=Root%!ObSubs% Root%!ObSubs%=H% SetStr(H%,SourTg%,"Acorn Archimedes !"+Task$, = S%=0: SetStr( GetSub(H%,SourTg%,S%),VersTg%,Version$, SetSub(H%,GedcTg%,0, : S%=0: SetStr( GetSub(H%,GedcTg%,S%),VersTg%,"5.3", DelTag(Root%,TrlrTg%) : Kill old trailer SetSub(Root%,TrlrTg%,0, Ensure last Modified%=Mod% SaveSubs(F%,O%,Level%) S%=O%!ObSubs% SaveObj(F%,S%,Level%) SaveSubs(F%,S%,Level%+1) S%=S%!ObNext% SaveObj(F%,O%,Level%) T%,Val$ ,T%=O%!ObTag%: T%?TagFlags% ProgTag% (Level%)+" "; Level%=0 Id(O%)+" "; TagStr(T%); /Val$= PrintStr(O%): Val$>"" #F%," "+Val$; #F%,"" SetFile(F$) : Now editing unmodified tree file F$ Scrap$: "" :TreeFile$="<"+ MT("UT")+">":F$=TreeLeaf$ :TreeFile$=F$ IcTxt(SaveWH%,SaIcFile%)=F$ Modified%= 8ModifiedShown%= Modified% : Force title bar redraw Write a report to text file F$ Report(F$) MT("CC")+" ("+ $+")" #F%: MT("SF")+" ("+ $+")" "Hourglass_On" Escape( WriteReport(F%) Escape( "Hourglass_Off" SetFileType(F$,ReportType%) F$<>Scrap$ $ IcTxt(RepoWH%,SaIcFile%)=F$ WriteReport(F%) CO%,FO%,Fam%,R%,S% Person%,ShowYearOnly% : Override globals ShowYearOnly%= #F%,TreeFile$ Person%=0 GetSub(Root%,IndiTg%,Person%) #F%,"" Name(Person%)+" ("+ Dates(Person%)+")" : R%= Father(Person%): #F%," Father: "+ Name(R%) : R%= Mother(Person%): #F%," Mother: "+ Name(R%) Fam%=0 GetSub(Person%,FamsTg%,Fam%) FO%= Val(Fam%) S%= GetVal(FO%,HusbTg%) 7 S%<>Person% #F%," Husband: "+ Name(S%) S%= GetVal(FO%,WifeTg%) 4 S%<>Person% #F%," Wife: "+ Name(S%) CO%=0 # GetSub(FO%,ChilTg%,CO%) . #F%," Child: "+ Name( Val(CO%)) WriteNotesFile(F%," ") ======================== File Operations ========================= Modified : Reflect modification in title bar ModifiedShown%=Modified% Redraw title bar %T$=TreeFile$: Modified% T$+=" *" 4!b%=MainWH%: "Wimp_GetWindowInfo",,b% : blk@4 $b%!76=T$ b%!32 1<<16 "Wimp_ForceRedraw",-1,b%!4,b%!16,b%!12,b%!16+44 ModifiedShown%=Modified% Return the length of File$ or -1 if not found FileLen(File$) Found%,L% "OS_File",17,File$ Found%,,,,L% Found%=1 SetFileType(File$,Type%) "OS_File",18,File$,Type% Delete file F$ if it exists DelFile(F$) "OS_File",6,F$ ============================ GEDCOM ============================== Root% points to a level -1 pseudo-object. Each object has a tag, a value, and a list of sub-objects. Object values are initially pointers to strings but GEDCOM cross-references (Ids) are replaced by pointers to the referenced objects with the ObRef% bit set. Ids% points to a list of Ids. Each Id has a pointer to the next Id, a pointer to the object it stands for, and a name. (Re)initialise everything, free all heap Reset SetFile("") IcTxt(RepoWH%,SaIcFile%)=ReportLeaf$ IcTxt(DrawWH%,SaIcFile%)=DrawLeaf$ SetEdit(0) ResetHeap CFontM%!32=-1 : Font menu heap pointer invalid Close(NoteWH%) NoteBuf%=0 InitHash : Hash table for looking up names Root%= Object(RootTg%,0) Person%=0 Force%=1 Load objects from a file and build a heirarchy under R%. If loading into an empty database (Reset%<>0) then R% is Root% otherwise add the new objects under a temporary root R% and then merge into Root%. LoadGed(F%,Reset%) Id%,Id$,Level%,O%,R%,SubTl%(),Tag$,Value$,T% Where to hang next object at each level. Root object is level -1. SubTl%(MaxLevel%):SubTl%()=0 CIds%=0 : No inter-file cross references Reset% R%=Root% Object(RootTg%,0) SubTl%(0)= Tail(R%) Skip to header #F%="0 HEAD" #F%=0 #F%=O% !) GedLine(F%,Level%,Id$,Tag$,Value$) Level%>=0 #. O%= Object( Tag(Tag$), String(Value$)) $6 SubTl%(Level%+1)=O%+ObSubs%:SubTl%(Level%+2)=0 %8 T%=SubTl%(Level%): T%=0 MT("BL")+": "+$b% &( !T%=O%:SubTl%(Level%)=O%+ObNext% Id$>"" (9 Id%= Alloc(IdName%+ (Id$)+1):$(Id%+IdName%)=Id$ )1 Id%!IdNext%=Ids%:Id%!IdObj%=O%:Ids%=Id% * XRef(R%) Ids%: Free(Ids%):Ids%=Ids%!IdNext%: Free ids Reset% Merge(R%): Free(R%) FindPerson Merge New%'s sub-objects into Root%'s. INDIs are sorted in by name, others are appended. Merge(New%) E%,O%,N%,P% Find tail of Root%'s subs Tail(Root%) O%=New%!ObSubs% N%=O%!ObNext% =2 O%!ObTag%=IndiTg% P%= Position(O%) P%=E% O%!ObNext%=!P%:!P%=O% P%=E% E%=O%+ObNext% O%=N% GedLine(F%, Level%, Id$, Tag$, Value$) I%,P% #F%:P%=b% White(?P%):P%+=1: ?P%=CR% Level%=-1: Ignore empty line I/Level%= ($P%) : Level number Level%=0 K- Digit($P%) MT("ML")+": "+$b% L/ "Hourglass_Percentage",100* Level%>MaxLevel% MT("BL")+": "+$b% Strip trailing spaces P2I%=P%+ ($P%)-1: White(?I%):I%-=1: :I%?1=CR% Q/I%= $P%," "): I%=0 MT("MG")+": "+$b% R5P%+=I% : Optional xref id ?P%= P%+=1:I%= $P%,"@") U$ I%=0 MT("BC")+": "+$b% Id$= $P%,I%-1) W5 P%+=I% : After trailing @ Id$="" ?P%=Space% P%+=1 : (Not really) optional delimiter [4I%= $P%," ") : Delimiter after tag? I% Tag$= $P%,I%-1) Tag$=$P%:I%= (Tag$) ]8Value$=$(P%+I%) : Optional line items White(C%)=C%=Tab% C%=LF% C%=Space% Lower($mess%) P%:P%=mess% ?P%<>CR% ?P%>= ?P%<= "z" ?P%=?P% f P%+=1 =$mess% Convert a pointer to a cross-ref id. Just use its word offset into the heap. Id(V%)="@"+ ((V%-Heap%)>>2)+"@" Set Person% to the person named in a level 0 NOTE or the last INDI FindPerson O%,Val$ O%=Root%!ObSubs% O%!ObTag% IndiTg%:Person%=O% NoteTg% Val$= Null(O%!ObVal%) y5 Val$,6)="Person" Person%= Find( Val$,8)): O%=O%!ObNext% Call PROCDeref for O% and its sub-objects recursively XRef(O%) Deref(O%) 1O%=O%!ObSubs%: XRef(O%):O%=O%!ObNext%: If O%'s value string is a GEDCOM pointer @id@ then replace it with a pointer to the object with that Id. Deref(O%) S$,Val%,Target% Val%=O%!ObVal%: Val%=0 ?Val%<> S$=$(Val%+1) S$,1)<>"@" Target%= IdObj( (S$)-1)) Target%=0 1,"Bad cross-reference "+$Val% Free(Val%) 5O%!ObVal%=Target% ObRef% : Flag as reference Return the object with Id$ IdObj(Id$) I%:I%=Ids% Id$="" 1,"FNIdObj" $(I%+IdName%)=Id$ =I%!IdObj% I%=I%!IdNext% Error:=0 MT("BC")+": "+Id$ ========================= GEDCOM edit ============================ Create a window to display and edit all GEDCOM fields. (Under construction). ObjEdit +!b%=ObEdWH%: "Wimp_GetWindowInfo",,b% /y%=b%!56 : Work max y OERecurse(Root%,-1,0,y%,-Infinity%,-Infinity%) b%!48=y%-8 "Wimp_DeleteWindow",,b% "Wimp_CreateWindow",,b%+4 ObEdWH% Open(ObEdWH%) DrawObEd(XW%,YW%,YMin%,YMax%) YW%-=8 OERecurse(Root%,-1,XW%+8,YW%,YMin%-CharH%,YMax%+CharH%) ObEdClick(Y%) YW%,S% ,!b%=ObEdWH%: "Wimp_GetWindowState",,b% YW%=b%!16-b%!24 OERecurse(Root%,-1,0,YW%,Y%+8,-Infinity%) S%=0 ?? PROCD(FNTagStr(S%!ObTag%)) If YW%Root% ProgTag% YW%=0 X%=XW%: Depth%>0 X%+=2*Depth%*CharW% Depth%=0 X%,YW%: Id(S%); X%+8*CharW%,YW%: TagStr(T%);" "; PrintStr(S%) YW%-=CharH%: YW% X%= OERecurse(S%,Depth%+1,XW%,YW%,YMin%,YMax%): S%=S%!ObNext% ============================= Tags =============================== Return the (new) tag with name T$ Tag(T$) T%:T%=Tags% $(T%+TagName%)=T$ T%=T%!TagNext% MkTag(T$) MkTag(T$) T% TagName%+ (T$)+1 T%?TagFlags%=0 T%!TagNext%=Tags% $(T%+TagName%)=T$ Tags%=T% TagStr(T%)=$(T%+TagName%) Initialise tags structures and linked list InitTags A tag is a pointer to a structure consisting of 5TagNext% =0 : Next tag pointer C : Other fields, e.g. help string .TagFlags%=4 : Flag byte CTagName% =5 : Variable length, CR terminated 9Tags%=0 : Pointer to first tag Tag flags DProgTag%=1 : Program only object - not saved Flag for PROCMark, PROCScan stored in object's tag pointer Dead%=1 Create tags used explicitly by code HeadTg%= MkTag("HEAD") SourTg%= MkTag("SOUR") VersTg%= MkTag("VERS") GedcTg%= MkTag("GEDC") TrlrTg%= MkTag("TRLR") IndiTg%= MkTag("INDI") NameTg%= MkTag("NAME") SexTg%= MkTag("SEX" ) DateTg%= MkTag("DATE") BirtTg%= MkTag("BIRT") DeatTg%= MkTag("DEAT") FamTg%= MkTag("FAM" ) NoteTg%= MkTag("NOTE") ContTg%= MkTag("CONT") FamsTg%= MkTag("FAMS") FamcTg%= MkTag("FAMC") HusbTg%= MkTag("HUSB") WifeTg%= MkTag("WIFE") ChilTg%= MkTag("CHIL") ProgTag% objects are for internal use only 6RootTg%= MkTag("root"):RootTg%?TagFlags%+=ProgTag% Display structure pointer 6DispTg%= MkTag("disp"):DispTg%?TagFlags%+=ProgTag% ============================ Syntax ============================== Load GEDCOM syntax description ?? Syntax F%,F$ F$=".GEDSyn" (F$): F%=0 MT("CR")+" "+F$ $b%= ?b% "#",CR%: Ignore comments and blank lines Print name Help string sub-objects ============================= Print ============================== Print F%,OldJob%,Page%,More%,x%,y%,dx%,dy%,N% Left%,Bottom%,Right%,Top%,Height%,Width% Following locals override PROCdisplay global work origin XW%,YW%:XW%=0:YW%=0 Error handler must be local so we can restore the old one Person%=0 MT("NP") OldJob%=-1:F%=0 PrintErr ("Printer:") "PDriver_SelectJob",F%,"Tree" OldJob% "PDriver_Info" ,,,N% 1<<29 "PDriver_DeclareFont",,Font$ "PDriver_DeclareFont" Get printable paper area limits in millipoints "PDriver_PageSize" ,,,Left%,Bottom%,Right%,Top% Size in OS units. 1 OS unit = 400 millipoints = 1/180". @HWidth%=(Right%-Left%) mPtPerOS%:Height%=(Top%-Bottom%) mPtPerOS% Rotate% Width%,Height% BAUseFont%= CalcAll : Recalculate positions for printing CBForce%=1 : Set to recalculate for screen D@Page%=1 : Identify rectangle to print Work area is (0,yMin%)..(xMax%,0). Allow overlap between pages F N%=(xMax%+Width%-1) Width% N%>1 dx%=(xMax%-Width%) (N%-1) dx%=Width% H#N%=(-yMin%+Height%-1) Height% N%>1 dy%=(-yMin%-Height%) (N%-1) dy%=Height% "Hourglass_On" y%=yMin% 0-Height% dy%: x%=0 xMax%-Width% Set work rectangle to print at b% in OS units. Top left = (0,0). M5 b%!0=x%:b%!4=y%:b%!8=x%+Width%:b%!12=y%+Height% Set transform table at b%+16. x'=(ax+cy)>>16 y'=(bx+dy)>>16 Print position of transformed bottom left at b%+32 in millipoints. Seascape (clockwise) is more natural than landscape (anticlockwise) for continuous paper since x=0 will be at the top. Rotate% SH b%!16=0:b%!20=-1<<16:b%!24=1<<16:b%!28=0 : Seascape x'=y y'=-x TH b%!32=Left%:b%!36=Top% : Rotate 90 clockwise VI b%!16=1<<16:b%!20=0:b%!24=0:b%!28=1<<16 : Portrait x'=x y'=y W@ b%!32=Left%:b%!36=Bottom% : No rotation "PDriver_GiveRectangle",Page%,b%,b%+16,b%+32,White% "PDriver_DrawPage",1,b%,Page%, (x%)+","+ More% More% \L Display(b%!0,b%!4,b%!8,b%!12,OutPrint%) : b% is work rect to print ]- "PDriver_GetRectangle",,b% More% Page%+=1 "Hourglass_Off" "PDriver_EndJob",F% "PDriver_SelectJob",OldJob% PrintErr OldJob%>=0 "PDriver_AbortJob",F% "PDriver_SelectJob",OldJob% "Hourglass_Smash" ========================= Write Draw file ======================== WriteDraw(F$) XW%,YW% : Override PROCdisplay global work origin "Hourglass_On" dw_open(F$) : open draw file dw_font(Font$) : set up font x@UseFont%= CalcAll : Recalculate positions for drawing yBForce%=1 : Set to recalculate for screen Draw with bottom left = 0,0 in infinite clip rectangle XW%=-xMin%:YW%=-yMin% Display(-Infinity%,-Infinity%,Infinity%,Infinity%,OutDraw%) dw_close F$<>Scrap$ $ IcTxt(DrawWH%,SaIcFile%)=F$ "Hourglass_Off" Open draw file and initialise variables dw_open(fnam$) dw_fh%= (fnam$): dw_fh%=0 dw_file$=fnam$ Initialise bounding box and font (dw_xmn%=Infinity%:dw_xmx%=-Infinity% (dw_ymn%=Infinity%:dw_ymx%=-Infinity% 0dw_ft%=0 : System font Write header #dw_fh%,"Draw";: dw_word(201): dw_word(0) #dw_fh%,"Family "; : Name must be 12 characters #dw_fh%=40 : Skip bounding box for now Terminate and close file dw_close dw_fh%=0 #dw_fh%=24 : Output bounding box dw_cd(dw_xmn%,dw_ymn%): dw_cd(dw_xmx%,dw_ymx%) #dw_fh%:dw_fh%=0 : Close draw file SetFileType(dw_file$, DrawType%) Make font object dw_font(font$) dw_fh%=0 dw_word(0) : Object type 0 dw_word(( (font$)+13) Length dw_ft%=1 #dw_fh%,dw_ft% dw_string(font$) Draw some text dw_text(x1%,y1%,size%,colour%,text$) dw_fh%=0 "Font_SetFont",Font% "Font_StringBBox",,text$ ,xx1%,yy1%,xx2%,yy2% Ax2%=x1%+(xx2%-xx1%) mPtPerOS%:y2%=y1%+(yy2%-yy1%) mPtPerOS% dw_word(1) : Object type 1 dw_word(( (text$)+56) Length dw_bx : 4 words of bounding box dw_word(colour%) : Text colour dw_word(&FFFFFF00) : Background colour dw_word(dw_ft%) : Font dw_word(size%*640*DrawScale): Nominal size of font dw_word(size%*640*DrawScale) dw_cd(x1%,y1%) : Start coords dw_string(text$) Output a null-terminated string. Pad to word boundary. dw_string(S$) #dw_fh%,S$; P%:P%= #dw_fh% #dw_fh%,0:P%+=1: P%=4 Draw a line dw_line(x1%,y1%,x2%,y2%,colour%) dw_fh%=0 dw_word(2) : Object type 2 dw_word(68) : Length dw_bx : 4 words of bounding box dw_word(-1) : No fill dw_word(colour%) dw_word(DrawWidth%) dw_word(0) : Style dw_word(2) : Move dw_cd(x1%,y1%) : Start coords dw_word(8) : DRAW dw_cd(x2%,y2%) : Start coords dw_word(0) : End path Output bounding box x1%,y1% - x2%,y2% dw_bx xx1%,yy1%,xx2%,yy2% 'xx1%=x1%:yy1%=y1%:xx2%=x2%:yy2%=y2% xx1%>xx2% xx1%,xx2% yy1%>yy2% yy1%,yy2% dw_cd(xx1%,yy1%): dw_cd(xx2%,yy2%) Update overall box Min(dw_xmn%,xx1%): Min(dw_ymn%,yy1%) Max(dw_xmx%,xx2%): Max(dw_ymx%,yy2%) Output coordinate pair. Convert from OS coords (1/180") to draw units (1/(180*256)"). dw_cd(X%,Y%) dw_word((X%<<8)*DrawScale): dw_word((Y%<<8)*DrawScale) Output word dw_word(word%) #dw_fh%,word%: #dw_fh%,word%>>8 #dw_fh%,word%>>16: #dw_fh%,word%>>24 ==================== Low-level memory allocation ================= Free% points after last block allocated or at lowest freed. Block starts with 4-byte count of following bytes. Count is multiple of 4. Bit 0 => block in use. Coalesce as much as possible on allocation. Only zero size block is last block. Musn't leave a zero size block when allocating part of a block. HeapFree% is total free space including count words of free blocks. ResetHeap HeapSize%=HeapEnd%-Heap% 6HeapLow%=0.05*HeapSize% : Warn if less free >!Heap%=HeapSize%-8 : 8 bytes = two count words ?Heap%!(HeapSize%-4)=0 : End marker: no bytes, free Free%=Heap% HeapFree%=HeapSize% @HeapWarn%=HeapLow% : Warn if less than this free Alloc(W%) E%,N%,S%,B% W%=0 W%=(W%+3) B%=Free% 3 S%=!B% 1 : Size of cur block S%=0 MT("OM") 0 N%=B%+4+S% : Next block (!B% 1)>0 :B%=N%:S%=0 (!N% 1)=0 !N%<>0:!B%+=!N%+4:S%=0 S%W% :E%=S%-W%-4 1 E% Free%=B%+4+W%:!Free%=E% B%=N%:S%=0 S%>=W% !B%=W% HeapFree%-=W%+4 =B%+4 Free block at A%. Freeing any number of objects will not disturb their contents. Free(A%) A%=0 A%-=4 (!A% 1)=0 1,"PROCFree not heap" (!A% 1)=0 1,"PROCFree size 0" !A%-=1 A%K$ D( b%!0=-1:b%!4=BarIc%:b%!8=0:b%!12=0 $BarIcText%=" " "Wimp_SetIconState",,b% $BarIcText%=K$ "Wimp_SetIconState",,b% HeapFree%>HeapWarn% K" " Val$= Line$,I%) SaveOpts (OptFile$) #F%,"Font:"+Font$ #F%,"PointSize:"+ PtSize% #F%,"ScreenUseFont:"+ ScreenUseFont% #F%,"ShowFamilyName:"+ ShowFamilyName% #F%,"ShowDates:"+ ShowDates% #F%,"ShowYearOnly:"+ ShowYearOnly% #F%,"Rotate:"+ Rotate% #F%,"DrawScale:"+ DrawScale #F%,"DrawWidth:"+ DrawWidth% Set up choices menu ShowOpts M%,MenuLen%,IndLen% "Font_ListFonts",,,1<<19 1<<21 ,,,MenuLen%,,IndLen% FontM%!32 points to font name submenu+indirect data if > 0 !M%=FontM%!32: M%>0 Free(M%) Alloc(MenuLen%+IndLen%) "Font_ListFonts",,M%,1<<19 1<<21,MenuLen%,M%+MenuLen%,IndLen%,Font$ FontM%!32=M% $FontSizeBuf%= (PtSize%)+ SelEntry(FontM%,2,ScreenUseFont%) SelEntry(FontM%,3,Rotate%) SelEntry(ShowM%,0,ShowFamilyName%) SelEntry(ShowM%,1,ShowDates%) SelEntry(ShowM%,2,ShowYearOnly%) "$DrawScaleBuf%= (DrawScale)+ #$DrawWidthBuf%= (DrawWidth%)+ Event in choices menu SetOpts(Choice1%,Choice2%,Choice3%,But%) F%,F$ Choice1% 0 : Font Choice2% Decode font id into mess% and copy to F$ K "Font_DecodeMenu",,FontM%!32,b%+12,mess%,messlen% ,,,F$,F% 0 FindFont(F$,PtSize%):Force%=1 1:F%= ($FontSizeBuf%) ) FindFont(Font$,F%):Force%=1 2:ScreenUseFont%= ScreenUseFont% Force%=1 3:Rotate%= Rotate% 1 : Show Choice2% 0:ShowFamilyName%= ShowFamilyName% 1:ShowDates%= ShowDates% 2:ShowYearOnly%= ShowYearOnly% Force%=1 2 : Draw Choice2% 0:DrawScale= ($DrawScaleBuf%) 1:DrawWidth%= ($DrawWidthBuf%) SaveOpts FindFont(F$,S%) O%:O%=Font% "Font_ReadScaleFactor" ,mPtPerOS% "Font_FindFont",,F$,16*S%,16*S% Font% "Font_LoseFont",O% Font$=F$:PtSize%=S% ========================== MessageTrans ========================== MTLoad(MTFile$) MTB% "OS_Module",6,,,17+ (MTFile$) ,,MTFile% : Allocate RMA $(MTFile%+16)=MTFile$ MTB% FileLen(MTFile$) "MessageTrans_OpenFile",MTFile%,MTFile%+16,MTB% Look up a token in the Messages file. No substitution allowed. MT(Tok$) L%,R% "MessageTrans_Lookup",MTFile%,Tok$ ,,R%,L% $(R%+L%)="" ========================== Quit & error ========================== Mods(".Q") ExtEdAbort Font% "Font_LoseFont",Font% Task% $b%="TASK": "Wimp_CloseDown",Task%,!b% Errors < 0 are expected - retain error handler and return. Error 0 is untrappable so won't be passed here. Errors > 0 are fatal - cancel error handler and quit. Error At$,R% >0 At$=" at line "+ +"!" At$="" :$(b%+4)= $+At$+ "Wimp_ReportError",b%,( 1,Task$ R%=2 NotOK(Query$) "!mess%=-1:$(mess%+4)=Query$+ "Wimp_ReportError",mess%,&13,Task$ 2=R%=2 : Cancel button If data modified open the "modified data" dbox and suspend the current load, reset or quit. Remember what to do if the user hits "Discard". Mods(F$) Modified% ToDo$=F$: MouseMenu(ModsWH%) =Modified% D(A$) B%,J% A$="" Debug%=0: "PDriver_SelectJob",0,0 4,26: 0,1);A$;".": "PDriver_SelectJob",J% Debug%=(Debug%+1) "Hourglass_Smash": "OS_Confirm" z%,z%,B%: B%=0 z=INKEY(100)