10 clear 2000:maxfiles=2 31 de=0:open "tests.ndp" for input as #3:rem master atom list 32 if not eof(3) then input#3,x\$,i%:else goto 36:rem counts atoms in file 33 nx=nx+1:goto 32:rem 36 close 3: ?i%" tests","nx="nx:open "tests.ndp" for input as #3 37 dim de\$(100),ww\$(nx),ci%(i%+1),ii%(nx),g\$(i%+1),as\$(1500),l\$(2000):for z%=1 to nx: input#3,ww\$(z%),ii%(z%):next z%:close 3:open "dirdat.lst" for input as #3 38 if not eof(3) then input#3,f\$:gosub 25000 :else close:?nx"END":system 39 f1\$ = f\$+".do":o\$ = f\$+".grd":en=1:open f1\$ for input as #1: open o\$ for output as #2:tg=0 40 if not eof(1) then l\$="":ac%=0:gosub 10000:else close 1:close 2:goto 38:rem get a line 50 if en=2 then goto 40 51 if tg=0 and en=1 then gosub 4200:goto 40 52 if tg=0 and en=0 then goto 4213 53 gosub 1000:gosub 5000:g\$(0)=a\$:rem clear the main array and assign the nomen to g\$(0) 54 for a%=1 to na%:rem for the rest of the atoms that have + or - 55 a\$=as\$(a%):rem get an atom a and put its r-member into the array 56 gosub 59 57 next a%:rem all done here now save it 58 goto 5800 59 rem scan data for keys and special cases 60 if tg=1 then w\$=left\$(a\$,3):wd%=3 69 if left\$(a\$,1)="\$" or instr(a\$,"?") then return 70 if instr(a\$,"=")then w\$=left\$(a\$,instr(a\$,"=")-1):t\$=right\$(a\$,len(a\$)-instr(a\$,"=")):wd%=len(w\$):? w\$ 72 if w\$= "tli" then goto 9000 : rem triple sugar lactose iron 73 if left\$(a\$,2)="t+" or left\$(a\$,2)="t-" then goto 6000 :rem TSI 74 if left\$(a\$,2)="s+" then goto 7000 75 if left\$(a\$,2)="s-" then goto 7000 76 if left\$(a\$,2)="g+" then goto 8000 77 if left\$(a\$,2)="g-" then goto 8000 78 if wd%=3 then t\$=right\$(a\$,len(a\$)-3):gosub 2000::if w\$= "dia" or w\$="len" or w\$="wid" then goto 9900 79 if t\$="Y" OR t\$="y" OR t\$="yes" OR t\$="YES" then t\$="+" 80 if instr(t\$,"-+") OR instr(t\$,"+-") then t\$="D" 81 z% = 1 :rem roam the atomlist for a match 82 if left\$(ww\$(z%),1)="/" and left\$(a\$,1)="/" then g\$(ii%(z%))=right\$(a\$,len(a\$)-1):goto 102 83 if instr(a\$,"Ox") AND left\$(a\$,5)=left\$(ww\$(z%),5) then g\$(ii%(z%))=right\$(a\$,2):goto 102 84 if left\$(ww\$(z%),1)="^" and left\$(a\$,1)="^" then g\$(ii%(z%))=right\$(a\$,len(a\$)-1):goto 102 85 if (tg=1 and len(ww\$(z%))=3 and w\$=ww\$(z%)) then g\$(ii%(z%))=t\$:goto 102 86 rem if w\$=left\$(ww\$(z%),3) then g\$(ii%(z%))=t\$:goto 100:rem puts + or - or -+ into g\$() 90 if w\$ = ww\$(z%) then g\$(ii%(z%))=t\$:goto 100:rem puts + or - or -+ into g\$() 100 z% = z% + 1 : if z% > nx then return else goto 82 101 t\$="" : rem last matching atom is assigned to the grid 102 return 1000 rem use l\$() put atoms into as\$(na%) 1001 na%=0:as\$(na%)="":for z%=0 to ac% 1002 if l\$(z%) ="," then na%=na%+1:as\$(na%)="":goto 1004 1003 as\$(na%)=as\$(na%)+l\$(z%) 1004 next z%:a%=0 1005 a\$=as\$(0):return:rem returns with nomen 2000 rem extension of 70 2020 if w\$ = "nit" and t\$ = "++" then g\$(329)= "+" 2021 if w\$ = "nit" and t\$ = "+" then g\$(329)= "-" 2022 if w\$ = "nit" and t\$ = "-" then g\$(329)= "-" 2030 return 4123 en=0:if left\$(l\$,4)="#tag" then ?"using tagged fields":tg=1:en=2:return 4124 if left\$(l\$,5)="#note" then ?l\$:en=2:return 4125 if left\$(l\$,7)="#define" then ?l\$:gosub 22000 :en=2:return 4127 tg=0:en=1:return 4200 gosub 1000:gosub 5000:g\$(0)=a\$:for a%=1 to na%:a\$=as\$(a%) 4202 xk=0:for z%=1 to nx:rem roam the tests for a match 4203 if a\$= ww\$(z%) then ci%(a%)=ii%(z%):xk=1: rem assign column to test 4204 next z% 4205 next a% 4206 if xk = 0 then print "*** no column assigned for ";a\$ 4207 return 4213 rem get first atom in a\$ and assume it is a nomen 4214 gosub 1000:gosub 5000:for a%=1 to na%:a\$=as\$(a%):gosub 9500 4220 if a\$="" then goto 4231 4230 g\$(ci%(a%))=a\$ 4231 next a%:g\$(0)=as\$(0) 4249 ix%=i%:goto 5800 5000 rem ?" clean grid";i%:stop 5010 for z%=1 to i%:g\$(z%)="":next z% 5011 return 5799 rem mop up morphology and save grid to disk 5800 if g\$(143)<>"" then gosub 5840:g\$(143)="":rem split size into length and width or diam 5801 if instr(g\$(159),"-") then gosub 5820: rem load width range 5802 if instr(g\$(160),"-") then gosub 5830: rem load length range 5803 if g\$(67)<>"" or g\$(71)<>"" then gosub 5811: rem load size range 5804 if g\$(95)<>"" then gosub 9954 : rem load diameter range 5805 if g\$(142)<>"" then gosub 5940 : g\$(142)="":rem morphology 5806 if g\$(95)="" and g\$(159)=g\$(160) then g\$(95)=g\$(159) 5809 g\$(69)="":g\$(70)="":g\$(71)="":g\$(72)="":g\$(67)="":g\$(68)="":if g\$(xxx)="+" then g\$(39)="-" 5810 goto 5950 5811 rem size range 5811 g\$(160)=str\$((val(g\$(67))+val(g\$(68)))/2) 5812 g\$(159)=str\$((val(g\$(71))+val(g\$(72)))/2) 5813 return 5820 rem width range 5821 g\$(71)=left\$(g\$(159),instr(g\$(159),"-")-1) 5822 g\$(72)=right\$(g\$(159),len(g\$(159))-instr(g\$(159),"-")) 5823 return 5830 rem length range 5831 g\$(67)=left\$(g\$(160),instr(g\$(160),"-")-1) 5832 g\$(68)=right\$(g\$(160),len(g\$(160))-instr(g\$(160),"-")) 5833 return 5840 if instr(g\$(143),"x")=0 then g\$(95)=g\$(143):return 5841 d1\$=left\$(g\$(143),instr(g\$(143),"x")-1) 5842 d2\$=right\$(g\$(143),len(g\$(143))-instr(g\$(143),"x")) 5843 if instr(d1\$,"-")<>0 then x1=val(left\$(d1\$,instr(d1\$,"-")-1)):else x1= val(d1\$):x2=x1:goto 5845 5844 x2=val(right\$(d1\$,len(d1\$)-instr(d1\$,"-"))) 5845 if instr(d2\$,"-")<>0 then y1=val(left\$(d2\$,instr(d2\$,"-")-1)):else y1= val(d1\$):y2=y1:goto 5847 5846 y2=val(right\$(d2\$,len(d2\$)-instr(d2\$,"-"))) 5847 xm=(x1+x2)/2 :ym=(y1+y2)/2 5848 if xm6 then print "grid: TSI error in "f1\$" item: "g\$(0) 6001 g\$(51)=mid\$(a\$,3,1):rem if g\$(51)="b" then g\$(51)="+" 6002 g\$(54)=mid\$(a\$,4,1):rem if g\$(54)="b" then g\$(54)="+" 6003 g\$(11)=mid\$(a\$,5,1):if g\$(11)="g" then g\$(11)="+" 6004 g\$(53)=mid\$(a\$,6,1):if g\$(53)="s" then g\$(53)="+" 6005 if instr(g\$(11),"a") then g\$(12)="+" 6060 t\$="":return 7000 g\$(57)=mid\$(a\$,2,1):if len(a\$)<>7 then print "grid: Sellers error in "f1\$" item: "g\$(0) 7001 g\$(59)=mid\$(a\$,3,1) 7002 g\$(60)=mid\$(a\$,4,1):if g\$(60)="b" then g\$(9)="+" else g\$(9)="-" 7003 g\$(61)=mid\$(a\$,5,1):if g\$(61)="y" then g\$(148)="+" else g\$(148)="-" 7004 g\$(62)=mid\$(a\$,6,1) 7005 g\$(63)=mid\$(a\$,7,1):if g\$(63)="+" then g\$(58)="++" 7006 t\$="":return 7999 rem grams 8000 g\$(14)=mid\$(a\$,2,1):if len(a\$)=3 then g\$(30)=right\$(a\$,1):return 8001 t\$="":return 9000 rem tli 9002 g\$(21)=mid\$(a\$,4,1):if len(a\$)<>7 then ? "grid: TLI error in "f1\$" item: "g\$(0):stop 9003 g\$(65)=mid\$(a\$,5,1) 9004 g\$(64)=mid\$(a\$,6,1) 9005 g\$(66)=mid\$(a\$,7,1) 9006 g\$(31)=mid\$(a\$,7,1):t\$="":return 9500 tm\$=a\$:if instr(a\$,"rod") then g\$(30)="r":a\$="":goto 9509 9501 if instr(a\$,"coc") or instr(a\$,"sph") then g\$(30)="c":a\$="":goto 9509 9502 if instr(a\$,"dip") then g\$(30)="d":a\$="":goto 9509 9503 if instr(a\$,"bac") then g\$(30)="b":a\$="":goto 9509 9504 if instr(a\$,"del") or instr(a\$,"ag") then a\$="+":return 9505 if instr(a\$,"spi") then g\$(30)="s":a\$="":goto 9509 9506 if instr(a\$,"a/-") or a\$="a" or a\$="b" then a\$="+":return 9507 if a\$="+-" OR a\$= "-+" then a\$="D":return 9509 if instr(tm\$,"g+") then a\$="":g\$(14)="+":if len(tm\$)=3 then g\$(30)=mid\$(a\$,instr(a\$,"g+")+2,1):return 9510 if instr(tm\$,"g-") then a\$="":g\$(14)="-":if len(tm\$)=3 then g\$(30)=mid\$(a\$,instr(a\$,"g+")+2,1):return 9511 return 9900 rem morphology screen: size and shape 9901 if w\$="wid" then g\$(159)=right\$(a\$,len(a\$)-3):return 9902 if w\$="len" then g\$(160)=right\$(a\$,len(a\$)-3):return 9903 if w\$="dia" then g\$(95)=right\$(a\$,len(a\$)-3):return 9954 if instr(g\$(95),"-") then gosub 9956 9955 g\$(159)=g\$(95):g\$(160)=g\$(95):return 9956 g\$(69)=left\$(g\$(95),instr(g\$(95),"-")-1) 9957 g\$(70)=right\$(g\$(95),len(g\$(95))-instr(g\$(95),"-")) 9958 g\$(95)=str\$((val(g\$(69))+val(g\$(70)))/2):return 10000 x\$=input\$(1,1):if asc(x\$)<>10 then l\$(ac%)=x\$:ac%=ac%+1:goto 10000 20000 ac%=ac%-2:z%=0 :rem unix users might want to change that 2 to a 1 20002 if asc(l\$(z%))=13 or l\$(z%)="," then goto 20005 20003 l\$=l\$+l\$(z%):rem l\$ contains only first atom of string 20004 z%=z%+1:goto 20002 : rem l\$() contains entire string of atoms 20005 en=0:if l\$(0)="#"then gosub 4123 20006 return 22000 rem define expansion 22001 de=de+1 22002 de\$(de)=right\$(l\$,len(l\$)-8) 22003 return 25000 ?"": ?f\$:if f\$="" then ?"NULL FILE":close:?nx"DONE":system:else return 25001 rem 