home *** CD-ROM | disk | FTP | other *** search
/ Nibble Magazine / nib41a.dsk / JUNE.1991 / NIBBLE.ANCESTRY.bas
BASIC Source File  |  2023-02-26  |  19KB  |  291 lines
  1. 10  REM  ************************
  2. 20  REM  * NIBBLE.ANCESTRY      *
  3. 30  REM  * BY JOSEPH STROUT     *
  4. 40  REM  * COPYRIGHT (C) 1991   *
  5. 50  REM  * MINDCRAFT PUBL. CORP.*
  6. 60  REM  * LINCOLN, MA 01773    *
  7. 70  REM  ************************
  8. 80  GOSUB 2740: GOSUB 1160: REM  SET-UP
  9. 90  REM  MAIN LOOP
  10. 100  GOSUB 2160:X2 = 2:Y2 = 1
  11. 110  GOSUB 2330
  12. 120 X = X2:Y = Y2: INVERSE : GOSUB 190: NORMAL : WAIT 49152,128: GET K$:K =  ASC(K$): IF K >31  THEN 590
  13. 130  IF K = 13  THEN 260
  14. 140  IF K < >8  AND K < >10  AND K < >11  AND K < >21  THEN 120
  15. 150  GOSUB 190:X = X -(K = 8  AND X >1) +(K = 21  AND X <4):Y = Y -(K = 11  AND Y >1) +(K = 10  AND ((X = 1  AND Y <2)  OR (X = 2  AND Y <1 +KL)  OR (X = 3  AND Y <S +KL)  OR (X = 4  AND Y <C +KL)))
  16. 160  IF X = 3  AND   NOT (S +KL)  THEN X = X -(K = 8) +(K = 21)
  17. 170  IF X = 4  AND   NOT (C +KL)  THEN X = 3: IF   NOT S  THEN X = 2
  18. 180 X2 = X:Y2 = Y: GOTO 120
  19. 190  IF X = 1  AND Y = 2  THEN X$ = M$: VTAB 15: GOTO 250
  20. 200  IF X = 1  THEN Y = 1:X$ = F$: VTAB 10: GOTO 250
  21. 210  IF X = 2  AND (Y = 1  OR LK = 1)  THEN Y = 1:X$ = N$: VTAB 12: HTAB 7: GOTO 250
  22. 220  IF X = 2  THEN Y = 2:X$ = "Change Info": VTAB 13: HTAB 7: GOTO 250
  23. 230  IF X = 3  THEN Y = Y *(Y < = S +KL) +(Y >S +KL):X$ = S$(Y): VTAB 12 -S/2 +Y: HTAB 33: GOTO 250
  24. 240  IF X = 4  THEN Y = Y *(Y < = C +KL) +(Y >C +KL):X$ = C$(Y): VTAB 12 -C/2 +Y: HTAB 57
  25. 250  PRINT " "X$" ": RETURN 
  26. 260  IF X = 2  AND Y = 2  THEN 490
  27. 270 A = DA(PP +1 +(Y = 2)) *(X = 1) +PP *(X = 2) +DA(PP +2 +Y) *(X = 3) +DA(PP +3 +S +Y) *(X = 4): IF A >0  THEN PP = A: GOTO 100
  28. 280  IF LK  THEN 120
  29. 290  VTAB 18: PRINT : CALL  -958:A$ =  MID$ ("FatherMotherSpouseChild", -5 +(X +(X = 1  AND Y = 2)) *6,6): PRINT "Enter full name of "A$", or <RETURN> to cancel:"
  30. 300  PRINT A$;: GOSUB 2710: IF A$ = ""  THEN 100
  31. 310  IF X >1  OR Y >1  THEN 350
  32. 320  GOSUB 2480:P1 = AP:P2 = PP: GOSUB 2530
  33. 330  IF DA(PP +2)  THEN P1 = AP:P2 = DA(PP +2): GOSUB 2640
  34. 340  GOTO 1140
  35. 350  IF X >1  THEN 390
  36. 360  GOSUB 2480:P1 = AP:P2 = PP: GOSUB 2590
  37. 370  IF DA(PP +1)  THEN P1 = AP:P2 = DA(PP +1): GOSUB 2640
  38. 380  GOTO 1140
  39. 390  IF X >3  THEN 420
  40. 400  GOSUB 2480:P1 = AP:P2 = PP: GOSUB 2640
  41. 410  GOTO 1140
  42. 420  GOSUB 2480:P1 = PP:P2 = AP: PRINT "Is "N$" the <F>ather or <M>other? ";
  43. 430  GET A$: IF A$ < >"M"  AND A$ < >"m"  AND A$ < >"F"  AND A$ < >"f"  THEN 430
  44. 440 A = (A$ = "M"  OR A$ = "m"): PRINT  MID$ ("FaMo",1 +A *2,2)"ther": PRINT : ON A +1 GOTO 450,470
  45. 450  GOSUB 2530: IF S  THEN  FOR J = 1 TO S: VTAB 21: PRINT : PRINT "Is "S$(J)" the mother? ";: GOSUB 2300: IF A$ = "Y"  THEN A$ = S$(J): GOSUB 2480:P1 = AP: GOSUB 2590:J = S +1
  46. 460  GOTO 480
  47. 470  GOSUB 2590: IF S  THEN  FOR J = 1 TO S: VTAB 21: PRINT : PRINT "Is "S$(J)" the father? ";: GOSUB 2300: IF A$ = "Y"  THEN A$ = S$(J): GOSUB 2480:P1 = AP: GOSUB 2530:J = S +1
  48. 480  ON (S >0) +1 GOTO 1140: NEXT J: GOTO 1140
  49. 490  VTAB 18: PRINT : CALL  -958:X = 2:A$ = ">" +NF$(DA(PP)): PRINT "Enter information about "N$", or <RETURN> to cancel:": VTAB 19: PRINT : CALL  -958: PRINT A$
  50. 500  VTAB 20 + INT((X -1)/80): HTAB X - INT((X -1)/80) *80
  51. 510  GET K$:K =  ASC(K$): IF K = 13  THEN 580
  52. 520  IF  LEN(A$) >238  AND K < >8  AND K < >127  THEN  FOR J = 1 TO 7:U =  PEEK(49200): NEXT : GOTO 510
  53. 530  IF K = 8  AND X >2  THEN X = X -1: PRINT K$;: GOTO 510
  54. 540  IF K = 21  AND X < =  LEN(A$)  THEN  PRINT  MID$ (A$,X,1);:X = X +1: GOTO 510
  55. 550  IF K >31  AND K <127  THEN A$ =  LEFT$(A$,X -1) +K$ + MID$ (A$,X): PRINT  MID$ (A$,X):X = X +1: GOTO 500
  56. 560  IF K = 127  AND X >2  THEN A$ =  LEFT$(A$,X -2) + MID$ (A$,X):X = X -1: PRINT  CHR$(8) MID$ (A$,X)" ": GOTO 500
  57. 570  GOTO 510
  58. 580 NF$(DA(PP)) =  MID$ (A$,2): GOTO 110
  59. 590 K = K -32 *(K >96):K$ =  CHR$(K): IF K$ = "I"  THEN 490: REM  GET INFO
  60. 600  IF K$ = "U"  AND  PEEK(49249) >127  THEN LK = 0:KL = 1: TEXT : HOME : GOSUB 1160: GOTO 100: REM  UNLOCK EDIT FUNCTIONS
  61. 610  IF K$ < >"Q"  THEN 640
  62. 620  VTAB 18: PRINT : CALL  -958: PRINT "Are you sure you want to quit? ";: GOSUB 2300: IF A$ = "Y"  THEN  TEXT : VTAB 23: END 
  63. 630  GOTO 110
  64. 640  IF K$ = "P"  THEN 870
  65. 650  IF LK  THEN  FOR X = 1 TO 5:U =  PEEK(49200): NEXT : GOTO 100: REM  EDIT COMMANDS HERE AFTER
  66. 660  VTAB 18: PRINT : CALL  -958: IF K$ < >"R"  THEN 700: REM  RENAME
  67. 670  PRINT "Enter new full name for "NA$(DA(PP))", or <RETURN> to cancel:"
  68. 680  GOSUB 2710: IF A$ < >""  THEN NA$(DA(PP)) = A$
  69. 690  GOTO 100
  70. 700  IF K$ < >"C"  THEN 800: REM  CUT LINK
  71. 710  IF X = 2  THEN  PRINT "You must highlight the person whom you wish to cut from": PRINT N$".": FOR X = 1 TO 5:U =  PEEK(49200): NEXT : GOTO 1150
  72. 720  PRINT "Are you sure you want to cut the link between": PRINT N$" and "X$"? ";: GOSUB 2300: IF A$ = "N"  THEN 1150
  73. 730 A$ = X$: GOSUB 2480:DA(PP +1) = DA(PP +1) *(DA(PP +1) < >AP):DA(PP +2) = DA(PP +2) *(DA(PP +2) < >AP):X = PP +3:Y = 0
  74. 740 Y = Y +(DA(X) = 0): IF DA(X) = AP  THEN A = X: GOSUB 2440: REM  DELETE DATUM
  75. 750  IF Y <2  THEN X = X +1: GOTO 740
  76. 760 DA(AP +1) = DA(AP +1) *(DA(AP +1) < >PP):DA(AP +2) = DA(AP +2) *(DA(AP +2) < >PP):X = AP +3:Y = 0
  77. 770 Y = Y +(DA(X) = 0): IF DA(X) = PP  THEN A = X: GOSUB 2440: REM  DELETE DATUM
  78. 780  IF Y <2  THEN X = X +1: GOTO 770
  79. 790  PRINT "OK.": GOTO 1150
  80. 800  IF K$ < >"L"  THEN 830: REM  LOCK EDIT OFF
  81. 810 LK = 1:KL = 0
  82. 820  TEXT : HOME : GOSUB 1160: GOTO 100
  83. 830  IF K$ = "K"  THEN 1880: REM  KEEP FILE  
  84. 840  IF K$ = "O"  THEN 1960: REM  OPEN FILE
  85. 850  FOR X = 1 TO 5:U =  PEEK(49200): NEXT : GOSUB 2330: GOTO 120
  86. 860  REM  PRINT
  87. 870  VTAB 18: PRINT : CALL  -958: PRINT "Print to:";:C = 1:A$(1) = " Printer ":A$(2) = " Textfile ":A$(3) = " (Cancel) "
  88. 880  HTAB 11: FOR J = 1 TO 3: POKE 50,255 -192 *(C = J): PRINT A$(J);: NEXT 
  89. 890  WAIT 49152,128: GET K$:K =  ASC(K$): IF K = 13  THEN 930
  90. 900 C = C -(K = 11  OR K = 8): IF C = 0  THEN C = 3
  91. 910 C = C +(K = 21  OR K = 10): IF C = 4  THEN C = 1
  92. 920  GOTO 880
  93. 930  NORMAL : IF C = 3  THEN 1150
  94. 940  PRINT : PRINT "Select report format:";:FM = 1:A$(1) = " Chart ":A$(2) = " List "
  95. 950  HTAB 23: FOR J = 1 TO 2: POKE 50,255 -192 *(FM = J): PRINT A$(J);: NEXT : WAIT 49152,128: GET K$: IF K$ < > CHR$(13)  THEN FM = 1 +(FM = 1): GOTO 950
  96. 960  ON (FM = 2) +1 GOTO 980: NORMAL : PRINT : PRINT "Select search direction:";:CP = 1:A$(1) = " Ancestors ":A$(2) = " Descendants "
  97. 970  HTAB 26: FOR J = 1 TO 2: POKE 50,255 -192 *(CP = J): PRINT A$(J);: NEXT : WAIT 49152,128: GET K$: IF K$ < > CHR$(13)  THEN CP = 1 +(CP = 1): GOTO 970
  98. 980  NORMAL : PRINT : INPUT "Enter title for report: ";T$: GOSUB 1700
  99. 990  HOME : IF C = 2  THEN 1030
  100. 1000  VTAB 10: PRINT  TAB( 20)"Prepare printer, press any key to print,": PRINT  TAB( 30)"or <ESC> to cancel: ";: GET A$: IF A$ =  CHR$(27)  THEN 100
  101. 1010  GOSUB 1740
  102. 1020 P = PP: GOSUB 1560: GOSUB 1780: PRINT : GOSUB 1160: GOTO 100
  103. 1030 A$ = "PRINT TO TEXTFILE: Enter name of file to create":R = 3: GOTO 1800
  104. 1040  IF F$ = ""  THEN 1150
  105. 1050  POKE 216,0: ONERR  GOTO 1100
  106. 1060  PRINT D$"VERIFY"F$: PRINT "WARNING: This file already exists!": PRINT "   Delete it (Y/N) ? ";
  107. 1070  GET A$:A$ =  CHR$( ASC(A$) -32 *( ASC(A$) >96)): IF A$ = "Y"  THEN  PRINT "Yes": GOTO 1110
  108. 1080  IF A$ = "N"  THEN  PRINT "No": GOTO 1030
  109. 1090  GOTO 1070
  110. 1100  IF  PEEK(222) < >6  THEN  PRINT "Sorry, error #" PEEK(222): GOTO 1150
  111. 1110  POKE 216,0: ONERR  GOTO 2060
  112. 1120  PRINT : PRINT D$"OPEN"F$: PRINT D$"CLOSE": PRINT D$"DELETE"F$: PRINT D$"OPEN"F$: PRINT D$"WRITE"F$
  113. 1130 P = PP: GOSUB 1560: PRINT D$"CLOSE": PRINT "Successfully written.": GOTO 1150
  114. 1140  PRINT "OK."
  115. 1150  VTAB 24: HTAB 27: PRINT "Press any key to continue.";: WAIT 49152,128: GET A$: GOSUB 2160: GOTO 110
  116. 1160  TEXT : PRINT : VTAB 1: INVERSE : PRINT "  NIBBLE ANCESTRY by Joseph J. Strout" TAB( 39)"Copyright (C) 1991 Mindcraft Publ. Corp." TAB( 80)" ";: NORMAL : PRINT "Use arrow keys to highlight relatives of the center person."
  117. 1170  PRINT "Press <RETURN> to move highlighted person to center.";: IF KL  THEN  PRINT  CHR$(8)",": PRINT "   or to add information to the database.";
  118. 1180  PRINT : PRINT "COMMAND KEYS: <P>rint Report   <Q>uit"
  119. 1190  IF LK  THEN  INVERSE : FOR I = 1 TO 80: PRINT " ";: NEXT : NORMAL : POKE 34,6: RETURN 
  120. 1200  PRINT "EDIT KEYS: <R>ename   <C>ut Link   <O>pen File   <K>eep File   <L>ock Edit Off"
  121. 1210  INVERSE : FOR I = 1 TO 80: PRINT " ";: NEXT : NORMAL : POKE 34,7: RETURN 
  122. 1220  REM  CHART-PRINTING ROUTINES
  123. 1230  IF  LEN(A$) <FW  THEN 1290
  124. 1240 SA = 0: FOR J = 1 TO  LEN(A$): IF  MID$ (A$,J,1) = " "  THEN SA = SA +1:S(SA) = J
  125. 1250  NEXT 
  126. 1260  IF SA = 1  THEN A$ =  LEFT$(A$,1) + MID$ (A$,S(1)): GOTO 1290
  127. 1270  IF S(SA) -S(SA -1) = 2  THEN SA = SA -1: GOTO 1260
  128. 1280 A$ =  MID$ (A$,1,S(SA -1) +1) + MID$ (A$,S(SA)): GOTO 1230
  129. 1290 A$ =  LEFT$(A$ +UL$,FW): RETURN 
  130. 1300  REM  PRINT GREAT-GRANDPARENT P AND PARENTS
  131. 1310  PRINT  SPC( FW *3 -1);US$(F);: IF  PEEK(49152) = 155  THEN  GET K$: POP : POP : POP : RETURN 
  132. 1320  IF P = 0  THEN  PRINT  SPC( FW +1)BL$: PRINT  SPC( FW *3)BL$"<": GOTO 1360
  133. 1330  IF DA(P +1) >0  THEN A$ = NA$(DA(DA(P +1))): GOSUB 1230: PRINT  SPC( FW +1)A$: GOTO 1350
  134. 1340  PRINT  SPC( FW +1)BL$
  135. 1350 A$ = NA$(DA(P)): GOSUB 1230: PRINT  SPC( FW *3)A$"<": IF DA(P +2) >0  THEN A$ = NA$(DA(DA(P +2))): GOSUB 1230: PRINT  SPC( FW *3 -1);DS$(F); SPC( FW +1);A$: RETURN 
  136. 1360  PRINT  SPC( FW *3 -1);DS$(F); SPC( FW +1);BL$: RETURN 
  137. 1370  REM  PRINT GRANDPARENT P AND ANCESTORS
  138. 1380 F2 = F:F = 1: IF P = 0  THEN 1440
  139. 1390 P2 = P:P = DA(P2 +1): GOSUB 1310: PRINT : REM  PRINT FATHER'S SIDE
  140. 1400  PRINT  SPC( FW *2 -1);US$(F2)
  141. 1410 A$ = NA$(DA(P2)): GOSUB 1230: PRINT  SPC( FW *2)A$: PRINT  SPC( FW *2 -1);DS$(F2)
  142. 1420 F = 0:P = DA(P2 +2): GOSUB 1310: REM  PRINT MOTHER'S SIDE
  143. 1430  RETURN 
  144. 1440  GOSUB 1310: PRINT : PRINT  SPC( FW *2 -1);US$(F2)
  145. 1450  PRINT  SPC( FW *2)BL$: PRINT  SPC( FW *2 -1);DS$(F2)
  146. 1460 F = 0: GOSUB 1310: RETURN 
  147. 1470  REM  PRINT PARENT P AND ANCESTORS
  148. 1480 F3 = F:F = 1: IF P = 0  THEN 1530
  149. 1490 P1 = P:P = DA(P1 +1):F = 1: GOSUB 1380: PRINT : PRINT  SPC( FW -1);US$(F3)
  150. 1500 A$ = NA$(DA(P1)): GOSUB 1230: PRINT  SPC( FW)A$: PRINT  SPC( FW -1);DS$(F3)
  151. 1510 P = DA(P1 +2):F = 0: GOSUB 1380
  152. 1520  RETURN 
  153. 1530  GOSUB 1380: PRINT : PRINT  SPC( FW -1);US$(F3): PRINT  SPC( FW)BL$: PRINT  SPC( FW -1);DS$(F3)
  154. 1540  PRINT :F = 0: GOSUB 1380: RETURN 
  155. 1550  REM  PRINT REPORT WITH ROOT OF P
  156. 1560  PRINT  SPC( FW *2.5 - LEN(T$)/2);T$: PRINT : IF FM = 2  THEN 1610
  157. 1570 US$(0) =  CHR$(92):US$(1) = " ":DS$(0) = " ":DS$(1) =  CHR$(47)
  158. 1580 P0 = P:P = DA(P0 +1):F = 1: GOSUB 1480: PRINT : PRINT : PRINT 
  159. 1590 A$ = NA$(DA(P0)): GOSUB 1230: PRINT A$: PRINT : PRINT : PRINT 
  160. 1600 P = DA(P0 +2):F = 0: GOSUB 1480: RETURN 
  161. 1610 A1 = 1:XP(1) = PP:AL = 0:L$ = "BASE:":LW = FW *5
  162. 1620 A2 = 0: PRINT L$: FOR K = 1 TO A1: PRINT : PRINT NA$(DA(XP(K))):A$ = NF$(DA(XP(K))): GOSUB 2340: IF   NOT DA(XP(K) +3)  THEN A$ = "No spouse.":J = 102: GOTO 1640
  163. 1630 A$ =  LEFT$("Spouses",6 + SGN(DA(XP(K) +4))) +": ": FOR J = 3 TO 98:A$ = A$ +NA$(DA(DA(XP(K) +J))):J = J +99 *(DA(XP(K) +J +1) = 0):A$ = A$ + LEFT$(" ,",1 +(J <99)): NEXT 
  164. 1640  PRINT A$: IF CP = 1  THEN  FOR J = 1 TO 2: ON (DA(XP(K) +J) = 0) GOTO 1660:A2 = A2 +1:XP(A1 +A2) = DA(XP(K) +J): GOTO 1660
  165. 1650  FOR J = J -98 TO 98:A2 = A2 +1:XP(A1 +A2) = DA(XP(K) +J): ON  SGN(XP(A1 +A2)) GOTO 1660:A2 = A2 -1:J = J +99
  166. 1660  NEXT J,K: PRINT : PRINT : IF   NOT A2  OR  PEEK(49152) = 155  THEN  RETURN 
  167. 1670  FOR J = 1 TO A2:XP(J) = XP(A1 +J): NEXT :A1 = A2:AL = AL +1: IF AL = 1  THEN L$ =  MID$ ("PARENTS CHILDREN",1 +8 *(CP = 2),8): GOTO 1620
  168. 1680  IF AL = 2  THEN L$ = "GRAND" +L$: GOTO 1620
  169. 1690 L$ = "GREAT-" +L$: GOTO 1620
  170. 1700  PRINT "Line Width: ";FW *5;: HTAB 13: INPUT "";A$: IF  VAL(A$)  THEN FW =  INT( VAL(A$)/5): GOTO 1720
  171. 1710  VTAB  PEEK(37): HTAB 16: PRINT FW *5
  172. 1720 BL$ =  LEFT$(BL$ +UL$,FW): RETURN 
  173. 1730  REM  *** PRINTER COMMANDS HERE ***
  174. 1740  POKE 33,1: POKE 34,23: HOME : PRINT 
  175. 1750  PRINT D$"PR#1": PRINT  CHR$(27) CHR$(15): PRINT  CHR$(27)"Q" CHR$(127): REM  EPSON RX-80, COMPRESSED TYPE 
  176. 1760  RETURN : REM  SUBSTITUTE YOUR OWN PRINTER COMMANDS HERE
  177. 1770  REM  *** DISABLE PRINTER ***
  178. 1780  PRINT  CHR$(27) CHR$(18): NORMAL : PRINT : PRINT D$"PR#3"
  179. 1790  RETURN : REM  AGAIN, YOU MAY NEED TO CHANGE FOR YOUR PRINTER
  180. 1800  REM  GET FILENAME F$
  181. 1810  HOME : PRINT : PRINT A$: PRINT "(or use ProDOS commands CATALOG or PREFIX, or <RETURN> to cancel) :": PRINT ">";: CALL  -657:B$ = ""
  182. 1820  FOR X = 512 TO 767: IF  PEEK(X) < >141  THEN B$ = B$ + CHR$( PEEK(X) -128): NEXT 
  183. 1830  IF B$ = ""  THEN F$ = "": GOTO 1870
  184. 1840 F$ = "": FOR I = 1 TO  LEN(B$):A =  ASC( MID$ (B$,I,1)):F$ = F$ + CHR$(A -32 *(A >95)): NEXT : IF F$ = "?"  THEN F$ = "CATALOG"
  185. 1850  IF F$ = "PREFIX"  THEN  PRINT D$F$: INPUT B$: PRINT B$: PRINT "Press any key: ": GET B$: GOTO 1810
  186. 1860  IF  LEFT$(F$,3) = "CAT"  OR  LEFT$(F$,6) = "PREFIX"  THEN  PRINT : PRINT D$F$: PRINT "Press any key: ";: GET B$: GOTO 1810
  187. 1870  ON R GOTO 1890,1970,1040
  188. 1880 A$ = "KEEP FILE: Enter a name for this database":R = 1: ON PD +1 GOTO 2860,1810
  189. 1890  IF F$ = ""  THEN 1950
  190. 1900  PRINT D$"OPEN"F$: PRINT D$"CLOSE": PRINT D$"DELETE"F$: PRINT D$"OPEN"F$: PRINT D$"WRITE"F$
  191. 1910  PRINT NN: FOR X = 1 TO NN: PRINT NA$(X): PRINT NF$(X): NEXT 
  192. 1920  PRINT ND: FOR X = 1 TO ND: PRINT DA(X): NEXT 
  193. 1930  PRINT D$"CLOSE"
  194. 1940  PRINT : PRINT "File saved successfully."
  195. 1950  PRINT : PRINT "Press any key to return to the editor: ";: GET A$: GOTO 100
  196. 1960 A$ = "OPEN FILE: Enter then name of the database to load":R = 2: ON PD +1 GOTO 2860,1810
  197. 1970  IF F$ = ""  THEN 2050
  198. 1980  PRINT D$"VERIFY"F$: PRINT : PRINT "Getting the file...": PRINT D$"OPEN"F$: PRINT D$"READ"F$
  199. 1990  INPUT NN: FOR X = 1 TO NN: INPUT NA$(X):NF$(X) = ""
  200. 2000  GET A$: IF A$ < > CHR$(13)  THEN NF$(X) = NF$(X) +A$: GOTO 2000
  201. 2010  NEXT X
  202. 2020  INPUT ND: FOR X = 1 TO ND: INPUT DA(X): NEXT 
  203. 2030  PRINT D$"CLOSE"
  204. 2040  PRINT : PRINT "File loaded successfully."
  205. 2050  PRINT : PRINT "Press any key: ";: GET A$: GOTO 100
  206. 2060 E =  PEEK(222):L =  PEEK(218) + PEEK(219) *256: IF E >21  OR E = 0  OR E = 16  THEN  PRINT "Applesoft error #"E" in line "L"." CHR$(7): END 
  207. 2070  IF E = 6  THEN  PRINT "File or path not found." CHR$(7): GOTO 2130
  208. 2080  IF E = 16  THEN  PRINT "Syntax error." CHR$(7): GOTO 2130
  209. 2090  IF E = 9  THEN  PRINT "Disk full." CHR$(7): GOTO 2130
  210. 2100  IF E = 13  THEN  PRINT "File type mismatch." CHR$(7): GOTO 2130
  211. 2110  IF E = 8  THEN  PRINT "Input/Output error." CHR$(7): GOTO 2130
  212. 2120  PRINT "Disk error #"E"."
  213. 2130  RESTORE : FOR X = 768 TO 777: READ A: POKE X,A: NEXT : CALL 768: DATA 104,168,104,166,223,154,72,152,72,96
  214. 2140  PRINT : PRINT "Press any key: ";: GET A$: ON R GOTO 1880,1960,1030
  215. 2150  END 
  216. 2160  GOSUB 2230: HOME : PRINT : VTAB 12: HTAB 8: PRINT N$: IF KL  THEN  HTAB 8: PRINT "Change Info"
  217. 2170  VTAB 9: PRINT "Father:": PRINT " "F$: VTAB 14: PRINT "Mother:": PRINT " "M$
  218. 2180  IF   NOT (S +KL)  THEN  VTAB 12: HTAB 31: PRINT "Unmarried": GOTO 2200
  219. 2190  VTAB 12 -S/2: HTAB 31: PRINT  LEFT$("Spouses",6 +(S >1))":": FOR X = 1 TO S +KL: HTAB 34: PRINT S$(X): NEXT 
  220. 2200  IF   NOT (C +KL)  THEN  VTAB 12: HTAB 55: PRINT "No children": GOTO 2220
  221. 2210  VTAB 12 -C/2: HTAB 55: PRINT  LEFT$("Children",5 +3 *(C >1))":": FOR X = 1 TO C +KL: HTAB 58: PRINT C$(X): NEXT 
  222. 2220  RETURN 
  223. 2230 X = PP +3:S = 0
  224. 2240  IF DA(X)  THEN S = S +1:S$(S) = NA$(DA(DA(X))):X = X +1: GOTO 2240
  225. 2250 X = X +1:C = 0
  226. 2260  IF DA(X)  THEN C = C +1:C$(C) = NA$(DA(DA(X))):X = X +1: GOTO 2260
  227. 2270 F$ = NA$(DA(DA(PP +1))):M$ = NA$(DA(DA(PP +2))):N$ = NA$(DA(PP))
  228. 2280 S$(S +1) = "Add Spouse":C$(C +1) = "Add Child"
  229. 2290  RETURN 
  230. 2300  CALL  -868: GET A$: IF A$ = "Y"  OR A$ = "y"  THEN  PRINT "Yes":A$ = "Y": RETURN 
  231. 2310  IF A$ = "N"  OR A$ = "n"  THEN  PRINT "No":A$ = "N": RETURN 
  232. 2320  GOTO 2300
  233. 2330 A$ = NF$(DA(PP)): VTAB 18: PRINT : CALL  -958
  234. 2340  IF  LEN(A$) <LW  THEN  PRINT A$: RETURN 
  235. 2350  FOR X = LW TO 1  STEP  -1: IF  MID$ (A$,X,1) < >" "  THEN  NEXT 
  236. 2360  PRINT  MID$ (A$,1,X -1):A$ =  MID$ (A$,X +1): GOTO 2340
  237. 2370  REM  MAKE ROOM TO INSERT DATUM AT LOCATION A
  238. 2380  IF A =  >ND  THEN ND = ND +1: RETURN 
  239. 2390 ND = ND +1: FOR X = ND TO A +1  STEP  -1:DA(X) = DA(X -1): NEXT 
  240. 2400 PP = PP +(PP =  >A)
  241. 2410 DA(A) = 0: FOR X = 1 TO ND:DA(X) = DA(X) +(DA(X) =  >A  AND DA(X) =  INT(DA(X))): NEXT : REM  UPDATE POINTERS TO MOVED NODES
  242. 2420  RETURN 
  243. 2430  REM  DELETE LOCATION A FROM DATA
  244. 2440 ND = ND -1: FOR X = A TO ND:DA(X) = DA(X +1): NEXT 
  245. 2450 PP = PP -(PP >A):AP = AP -(AP >A): FOR X = 1 TO ND:DA(X) = DA(X) *(DA(X) < >A) -(DA(X) >A  AND DA(X) =  INT(DA(X))): NEXT 
  246. 2460  RETURN 
  247. 2470  REM  RETURN POINTER AP TO NODE NAMED A$ (CREATE IF NOT EXISTING)
  248. 2480  FOR Y = 1 TO ND: IF DA(Y) < > INT(DA(Y))  THEN  IF A$ = NA$(DA(Y))  THEN AP = Y:Y = ND +1: NEXT : RETURN 
  249. 2490  NEXT 
  250. 2500 NN = NN +1:NA$(NN) = A$:ND = ND +1:DA(ND) = NN +.1: FOR X = 1 TO 4:DA(ND +X) = 0: NEXT : REM  CREATE NEW NODE
  251. 2510 AP = ND:ND = ND +4: RETURN 
  252. 2520  REM  CONNECT P1 TO P2 AS FATHER-CHILD
  253. 2530 A = P1 +3:B = 0
  254. 2540 B = B +(DA(A) = 0): IF B <2  AND DA(A) < >P2  THEN A = A +1: GOTO 2540: REM  FIND DAD'S CHILDPTR INSERT POINTER
  255. 2550  IF DA(A) < >P2  THEN  GOSUB 2380:P2 = P2 +(P2 >A):DA(A) = P2: REM  SET DATD'S CHILD PTR
  256. 2560 DA(P2 +1) = P1: REM  SET CHILD'S DADPTR
  257. 2570  RETURN 
  258. 2580  REM  CONNECT P1 TO P2 AS MOTHER-CHILD   
  259. 2590 A = P1 +3:B = 0
  260. 2600 B = B +(DA(A) = 0): IF B <2  AND DA(A) < >P2  THEN A = A +1: GOTO 2600
  261. 2610  IF DA(A) < >P2  THEN  GOSUB 2380:P2 = P2 +(P2 >A):DA(A) = P2
  262. 2620 DA(P2 +2) = P1: RETURN 
  263. 2630  REM  CONNECT P1 TO P2 AS SPOUSE-SPOUSE
  264. 2640 A = P1 +3
  265. 2650  IF DA(A)  THEN A = A +1: GOTO 2650
  266. 2660  FOR J = P1 +3 TO A: IF DA(J) < >P2  THEN  NEXT : GOSUB 2380:P2 = P2 +(P2 >A):DA(A) = P2
  267. 2670 A = P2 +3
  268. 2680  IF DA(A)  THEN A = A +1: GOTO 2680
  269. 2690  FOR J = P2 +3 TO A: IF DA(J) < >P1  THEN  NEXT : GOSUB 2380:P1 = P1 +(P1 >A):DA(A) = P1
  270. 2700  RETURN 
  271. 2710  FOR J = 1 TO 2: FOR I = 1 TO 7:U =  PEEK(49200 *(I <7)): NEXT I,J
  272. 2720  PRINT "Name-->"; LEFT$(UL$,20);: HTAB  PEEK(1403) -19: INPUT "";A$:A$ =  LEFT$(A$,20): RETURN 
  273. 2730  REM  INIT ROUTINE
  274. 2740 MN = 200:MD = MN *10: REM  ABOUT 200 PERSON CAPACITY
  275. 2750  DIM NA$(MN),NF$(MN),DA(MD),S$(15),C$(20),XP(MN)
  276. 2760 SP = 1:PP = 1:DA(SP) = 1.1:NA$(DA(SP)) = "Empty Base":NA$(0) = "Unknown"
  277. 2770 NN = 1:ND = 5: REM  NUMBER OF NAMES, DATA
  278. 2780 LK = 0:KL =   NOT (LK): REM  EDIT LOCK
  279. 2790 FW = 25:LW = 80: REM  FW=FIELD WIDTH (PRINTER WIDTH/5)
  280. 2800  TEXT : HOME : PRINT  CHR$(4)"PR#3": PRINT : ONERR  GOTO 2060
  281. 2810 D$ =  CHR$(4):H$ =  CHR$(8)
  282. 2820 UL$ = "": FOR J = 1 TO 80:UL$ = UL$ + CHR$(95): NEXT 
  283. 2830 BL$ = "Unknown"
  284. 2840 PD =  PEEK(978): IF PD = 190  THEN PD = 1: RETURN 
  285. 2850 PD = 0: RETURN 
  286. 2860  HOME : PRINT : PRINT A$: PRINT "(Use CATALOG or '?' to list files, <RETURN> to cancel) :": PRINT ">";: CALL  -657:B$ = ""
  287. 2870  FOR X = 512 TO 767: IF  PEEK(X) < >141  THEN B$ = B$ + CHR$( PEEK(X) -128): NEXT 
  288. 2880  IF B$ = ""  THEN F$ = "": GOTO 2910
  289. 2890 F$ = "": FOR I = 1 TO  LEN(B$):A =  ASC( MID$ (B$,I,1)):F$ = F$ + CHR$(A -32 *(A >95)): NEXT : IF F$ = "?"  THEN F$ = "CATALOG"
  290. 2900  IF F$ = "CATALOG"  THEN  PRINT : PRINT D$F$: PRINT "Press any key: ";: GET B$: GOTO 2860
  291. 2910  ON R GOTO 1890,1970,1040