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