rem this file is "pSurvex-7-14" rem see include file, "pSurvex.oph" for rem compile time options rem wish list rem ~~~~~~~~~ rem rem offering to plot elevation angle rem *calibrate rem *include rem trap errors in reading .svx files rem - and print line numbers rem allow > 500 stations (hack) rem allow > 500 stations (rewrite) rem blank lines (test thoroughly) rem allow longer survey names rem error if output file cannot be opened rem integrated output file viewer rem integrated text editor include "pSurvex.oph" declare external const VERSION$="pSurvex 0.15 (beta) (Series 5)" APP pSurvexß,&093B7073 rem tab ; p s rem FLAGS 1 rem use documents ENDA PROC init: rem Station Heads "data structure" rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ global sCount% rem How many station heads are we using ? global sMax% rem What's the limit before we must reallocate the array ? global sName$(ALU%,SNL%) rem Friendly name for station global sLegHead%(ALU%) rem Link to first leg node from this station global sRevLegHead%(ALU%) rem Link to first reverse leg node back to this station global sFlags%(ALU%) rem Flags for this station global sSurvey%(ALU%) rem Which survey does this station belong to ? global sNext%(ALU%) rem Next station in Survey global sEast(ALU%),sNorth(ALU%),sAlt(ALU%) rem Legs "data structure" rem ~~~~~~~~~~~~~~~~~~~~~ global legCount% rem the number of allocated legs global legMax% rem the maximum number of legs available before a realloc global legFrom%(ALU%) rem the station that this leg is from global legFromSib%(ALU%) rem the next leg in the list of legs from the above station global legTo%(ALU%) rem the station that this leg is to global legToSib%(ALU%) rem the next leg in the list of legs to the above station global legTape(ALU%) rem tape reading global legCompass(ALU%) rem compass reading global legClino(ALU%) rem clino reading global legFlags%(ALU%) rem flags for this station rem Survey "data structure" rem ~~~~~~~~~~~~~~~~~~~~~~~ global survName$(40,SNL%) rem FIXME global survParent&(40) global survCurTapeCalib(40) global survCurCompassCalib(40) global survCurClinoCalib(40) global survFlags%(40) global survDaughter&(40) global survSister&(40) global survHead%(40) rem list of stations in this survey global survTail%(40) rem the last station in this survey global survCount% global survMax% global survCurrent% rem Misc global variables rem ~~~~~~~~~~~~~~~~~~~~~ global statusLast% rem what was the last line angle drawn ? global DEBUG% rem are we degugging ? rem Memory management stuff rem ~~~~~~~~~~~~~~~~~~~~~~~ global stringTable&, nextString&, maxString& global surveys&, nextSurvey&, maxSurvey& rem, sizeofSurvey% global stations&, nextStation&, maxStation& rem, sizeofStation% global legs&, nextLeg&, maxLeg& rem, sizeofLeg% rem sizeofSurvey%=sizeofLONG*6 + sizeofFLOAT*3 + sizeofINT rem sizeofStation%=sizeofLONG*5 + sizeofFLOAT*3 + sizeofINT rem sizeofLeg%=sizeofLONG*4 + sizeofFLOAT*3 + sizeofINT stringTable& = alloc(stringALU%) surveys& = alloc(sizeofSurvey% * surveyALU%) stations& = alloc(sizeofStation% * stationALU%) legs& = alloc(sizeofLeg% * legALU%) if (stringTable&=0) or (surveys&=0) or (stations&=0) or (legs&=0) dInit("Error") dText "","Unable to allocate memory." dText "","Close some other programs and" dText "","try again, or lower allocation sizes" dText "","in pSurvex.oph and recompile" dButtons "OK",(13 or $300) dialog stop endif nextString& = stringTable& nextSurvey& = surveys& nextStation& = stations& nextLeg& = legs& maxString& = stringTable& + stringALU% maxSurvey& = surveys& + sizeofSurvey% * surveyALU% maxStation& = stations& + sizeofStation% * stationALU% maxLeg& = legs& + sizeofLeg% * legALU% rem ATNOW rem now do something with ... rem ~~~~~~~~~~~~~~~~~~~~~~~~~ print VERSION$; " initialising..." sMax% = ALU% legMax% = ALU% survMax% = 40 rem FIXME survCurrent% = 1 survCount% = 1 screen 88,12 main: ENDP PROC main: external screenWidth%,DEBUG% local file$(255),off%(6),places&,fIni%,error% places&=2 rem setpath(PATH$) cls gCreate(0,0,640,40,1) rem Title window gStyle 9 :gAt 8,26 :gPrint VERSION$ rem Title text gAt 0,36 :gFill 640,3,0 rem Title rule gCreate(0,210,640,30,1) rem Status Window gFill 640,3,0 rem Status rule error% = ioopen(fIni%,"d:\system\apps\pSurvex\pSurvex.ini",$0020) if error%=0 error%=ioread(fIni%,addr(file$)+1,255) pokeb addr(file$),error% else file$="C:\Documents\*.svx" if error% <> -33 rem file does not exist print "Error, ";err$(error%);" reading .ini file" endif endif ioclose (fIni%) statusText:("waiting for file selector...") dInit VERSION$ dFile file$,"file,folder,disk",146 dLong places&,"Decimal places to output",0,9 if ALLOWDEBUG% :dCheckBox DEBUG%,"Debug Mode" :endif dButtons "Cancel",-27,"OK",13 statusText:("") if dialog=0 :stop :endif setdoc file$ error% = ioopen(fIni%,"d:\system\apps\pSurvex\pSurvex.ini",$0122) if error% = 0 iowrite(fIni%,addr(file$)+1,len(file$)) else print "Error, ";err$(error%);" writing to .ini file" endif ioclose(fIni%) parse$(file$,"",off%()) lopen left$(file$,off%(5)-1)+".pos.txt" readFile:(file$) statusText:("Computing...") compute: statusText:("Writing positions to file...") doOutput:(places&) ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem This procedure takes a filename and passes rem it line by line to the parser. Welcome to rem the hell that is EPOCs / OPL file io ! rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC readFile:(filename$) global line$(LINELENGTH%) local fin%, err%, ptr&, lc% err% = ioopen(fin%,filename$,$0020) if err% print "Error "; err%; " opening file"; filename$ lprint "Error "; err%; " opening file"; filename$ else statusText:("parsing file: "+filename$) ptr& = addr(line$) while err% <> -36 lc%=lc%+1 statusText:("parsing line "+fix$(lc%,0,5)+" in file: "+filename$) err% = ioread(fin%,ptr&+1,LINELENGTH%) if (err% >= 0) pokeb ptr&,err% parseLine: status: elseif (err% = -43) lprint "Warning line ";lc%;" is over "; LINELENGTH%; " characters in length. Modifier header file to change line length limit" print "Warning line ";lc%;" is too long" pokeb ptr&,LINELENGTH% parseLine: elseif (err% <> -36) print "Error "; err% ;" reading source file" endif endwh endif ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem This procedure will ultimately reallocate rem memory when we run out of room in the tree rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC growTree: rem reallocate sn*() to snMax+=ALU or die print "out of memory error (limited to "; ALU%; " stations at the moment)" get stop ENDP PROC parseLine: external line$ global count% local token$(LINELENGTH%) rem print line$ token$=nextToken$: if asc(mid$(token$,1,1))=%* token$=upper$(token$) @("parse"+(mid$(token$,2,len(token$)))): elseif token$="" rem noop else parseData:(token$) endif ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem this procedure looks at line$ and rem returns the next token from the rem count%+1 character and advances count% rem to the last character in the token rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC nextToken$: external line$,count% local token$(LINELENGTH%), ch$(1), chAsc% do count%=count%+1 ch$ = mid$(line$,count%,1) chAsc% = asc(ch$) until (chAsc%<>32) and (chAsc%<>9) and (chAsc%<>0) while (chAsc%<>32) and (chAsc%<>9) and (chAsc%<>0) and (chAsc%<>%;) token$=token$+ch$ ch$ = mid$(line$,count%+1,1) chAsc% = asc(ch$) count%=count%+1 endwh count%=count%-1 rem print "token: ";token$ return token$ ENDP PROC parseData:(token1$) local token$(LINELENGTH%), from$(SNL%), to$(SNL%), tape, compass, clino rem print "parseData" from$ = token1$ to$ = nextToken$: token$=nextToken$: tape = val(token$) if (tape<=0) or (tape>100) print "WARNING suspicious tape reading, ";tape;" from ";from$;" to ";to$ endif token$ = upper$(nextToken$:) if token$="UP" compass=999 clino=90 elseif token$="DOWN" compass=999 clino=-90 else if token$="-" compass=999 else compass=val(token$) if (compass < 0) or (compass > 359) print "Warning suspicious compass reading, ";compass;" from ";from$;" to ";to$ endif endif token$=upper$(nextToken$:) if token$="UP" clino = 90 elseif token$="DOWN" clino = -90 else clino=val(token$) if (clino>90) or (clino<-90) print "WARNING suspicious clino reading, ";clino;" from ";from$;" to ";to$ endif endif endif addleg:(from$,to$,tape,compass,clino,0) ENDP PROC parseBegin: external line$, count%, survParent%(), survCurrent%, survName$(), survMax%, survCount% local newSurvey$(LINELENGTH%), surv% newSurvey$ = nextToken$: survCurrent%=getSurvey&:(newSurvey$,survCurrent%) ENDP PROC getSurvey&:(name$,root&) external survParent&(),survCurrent%,survName$(),survMax%,survCount%,survDaughter&(),survSister&() local surv& surv&=survDaughter&(root&) while surv&<>0 if upper$(survName$(surv&))=upper$(name$) break endif surv&=survSister&(surv&) endwh if surv&=0 if survCount%=survMax% growTree: endif survCount%=survCount%+1 survParent&(survCount%)=root& surv&=survDaughter&(root&) if surv& = 0 survDaughter&(root&)=survCount% else while survSister&(surv&)<>0 surv&=survSister&(surv&) endwh survSister&(surv&)=survCount% endif surv&=survCount% survName$(surv&)=name$ endif return surv& ENDP PROC parseEnd: external line$, count%, survName$(), survCurrent%, survParent&() local token$(SNL%) token$=nextToken$: if survCurrent%=0 print "Warning *END "; token$; " in root survey" elseif upper$(token$)<>upper$(survName$(survCurrent%)) print "Warning expecting *END "; survName$(survCurrent%); " got *END "; token$ else survCurrent%=survParent&(survCurrent%) endif ENDP PROC parseFix: external line$, count%,sEast(),sNorth(),sAlt(),sFlags%() local station$(SNL%),sn%,east,north,alt station$=nextToken$: east=val(nextToken$:) north=val(nextToken$:) alt=val(nextToken$:) sn%=getStation&:(station$) sEast(sn%)=east sNorth(sn%)=north sAlt(sn%)=alt sFlags%(sn%)=sFlags%(sn%) or flagCALC% ENDP PROC parseEquate: external line$, count% local from$(LINELENGTH%),to$(LINELENGTH%) from$ = nextToken$: to$ = nextToken$: addleg:(from$,to$,0,888,0,0) ENDP PROC parseInclude: external line$, count% cls print "ERROR *INCLUDE unimplemented at present" get stop ENDP PROC parseExport: external line$, count% ENDP PROC parseFlags: rem external line$, count%, survFlags%(), survCurrent% rem local token$(SNL%),off%,flag% rem token$=upper$(nextToken$:) rem while token$<>"" rem if token$="NOT" rem off%=-1 rem else rem if token$="SURFACE": flag%=flagSURFACE% rem else rem print "Flag "+token$+" not recognised" rem endif rem if off% rem survFlags%(thisSurv%)=survFlags%(thisSurv%) and not(flag%) rem else rem survFlags%(thisSurv%)=survFlags%(thisSurv%) or flag% rem endif rem endif rem token$=upper$(nextToken$:) rem endwh ENDP PROC parseTeam: external line$, count% rem print "parseTeam" ENDP PROC parseCalibrate: external line$, count% rem print "parseCalibrate" ENDP PROC parseDate: external line$, count% rem print "parseDate" ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem this procedure takes data and adds it to rem the tree. rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC addLeg:(from$, to$, tape, compass, clino, flags%) local fromStation&, toStation&, leg& fromStation& = getStation&:(from$) toStation& = getStation&:(to$) leg& = newLeg&:(fromStation&,toStation&) setleg:(leg&, tape, compass, clino, flags%) ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem This procedure traverses the tree and rem computes the survey rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC compute: rem this is quick and dirty. It doesn't rem really traverse the tree at all - need to rem use a stack for that. We also need a chain rem of positions for each station so we can do rem loop closures (or put with the leg data) external sCount%,sName$(),sLegHead%(),sRevLegHead%(),sFlags%(),sEast(),sNorth(),sAlt(),legCount%,legFromSib%(),legTo%(),legTape(),legCompass(), legToSib%(),legClino(),legFlags%(),legFrom%(),DEBUG% local changes%,s%,s2%,dE,dN,dA,tape,compass,clino,d2r,leg% rem first of all should see if there are any fixed points s%=0 :while s%-1 sFlags%(1)=sFlags%(1) or flagCALC% print "WARNING: no fixed points, fixing station ";sName$(1);" to 0,0,0" endif changes%=1 :while changes%=1 :changes%=0 s%=0 :while s%0 s2%=legTo%(leg%) if DEBUG% :print "leg from ";sName$(s%);" to ";sName$(s2%) :endif if (sFlags%(s2%) and flagCALC%)<>flagCALC% if DEBUG% :print "computing from ";sName$(s%);" to ";sName$(s2%);" " :endif rem can't do loop closures this way ! tape=legTape(leg%) compass=rad(legCompass(leg%)) clino=rad(legClino(leg%)) dE=sin(compass)*cos(clino)*tape dN=cos(compass)*cos(clino)*tape dA=sin(clino)*tape sEast(s2%)=sEast(s%)+dE sNorth(s2%)=sNorth(s%)+dN sAlt(s2%)=sAlt(s%)+dA if DEBUG% :print " dE=";intf(dE*100)/100;" dN=";intf(dN*100)/100;" dA=";intf(dA*100)/100 :endif if DEBUG% :print " s2@";intf(sEast(s2%)*100)/100;", ";intf(sNorth(s2%)*100)/100;", ";intf(sAlt(s2%)*100)/100 :endif rem if DEBUG% :print :get : endif sFlags%(s2%)=sFlags%(s2%) or flagCALC% changes%=1 endif leg%=legFromSib%(leg%) endwh leg%=sRevLegHead%(s%) while leg%<>0 s2%=legFrom%(leg%) if DEBUG% :print "reverse leg from ";sName$(s%);" to ";sName$(s2%) :endif if (sFlags%(s2%) and flagCALC%)<>flagCALC% if DEBUG% :print "computing from ";sName$(s%);" to ";sName$(s2%);" (reverse leg) " :endif tape=legTape(leg%) compass=rad(legCompass(leg%)+180) clino=rad(legClino(leg%)*-1) dE=sin(compass)*cos(clino)*tape dN=cos(compass)*cos(clino)*tape dA=sin(clino)*tape sEast(s2%)=sEast(s%)+dE sNorth(s2%)=sNorth(s%)+dN sAlt(s2%)=sAlt(s%)+dA if DEBUG% :print " dE=";intf(dE*100)/100;" dN=";intf(dN*100)/100;" dA=";intf(dA*100)/100;" " :endif if DEBUG% :print " s2@";intf(sEast(s2%)*100)/100;", ";intf(sNorth(s2%)*100)/100;", ";intf(sAlt(s2%)*100)/100;" " :endif rem if DEBUG% :print :get :endif sFlags%(s2%)=sFlags%(s2%) or flagCALC% changes%=1 endif leg%=legToSib%(leg%) endwh endif endwh endwh ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem This creates and returns the index of a rem new blank entry in the leg structure rem for given station indices rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC newLeg&:(from&,to&) external sLegHead%(), sRevLegHead%(), legFrom%(), legFromSib%(), legTo%(), legToSib%(), legCount%, legMax%, sMax%, sName$() local node% if (from&=0) or (to&=0) or (from&>sMax%) or (to&>sMax%) growTree: endif legCount% = legCount% + 1 legFrom%(legCount%)=from& legTo%(legCount%)=to& if sLegHead%(from&)=0 sLegHead%(from&)=legCount% else node% = sLegHead%(from&) while legFromSib%(node%)<>0 node%=legFromSib%(node%) endwh legFromSib%(node%)=legCount% endif if sRevLegHead%(to&)=0 sRevLegHead%(to&)=legCount% else node% = sRevLegHead%(to&) while legToSib%(node%)<>0 node%=legToSib%(node%) endwh legToSib%(node%)=legCount% endif rem print "Created new leg, "; legCount%; "(for station ";sName$(from&);" - ";sName$(to&);")" return legCount% ENDP rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ rem This returns the station index for a rem given station name, creating one if it rem the station name isn't found amongst rem those listed rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ PROC getStation&:(pname$) external sCount%, sMax%, sName$(), survHead%(), survCurrent%, survName%(), survParent%(), survCount%(), survMax%, sSurvey%(), sNext%(), survDaughter%(), survTail%() local stat%, surv%, subSurvey$(LINELENGTH%),name$(LINELENGTH%) name$=pName$ surv%=survCurrent% while loc(name$,".")<>0 subSurvey$=left$(name$,loc(name$,".")-1) name$=right$(name$,len(name$)-loc(name$,".")) surv%=getSurvey&:(subSurvey$,surv%) rem print subSurvey$;" . ";name$ endwh stat%=survHead%(surv%) while stat%<>0 if upper$(sName$(stat%))=upper$(name$) :break :endif stat%=sNext%(stat%) endwh if stat%=0 if sCount%=sMax% growTree: endif sCount%=sCount%+1 stat%=sCount% sName$(stat%)=name$ if survHead%(surv%)=0 survHead%(surv%)=stat% else sNext%(survTail%(surv%))=stat% endif survTail%(surv%)=stat% endif return stat% ENDP PROC setLeg:(index&,tape,compass,clino,flags%) external legTape(), legCompass(), legClino(), legFlags%() legTape(index&)=tape legCompass(index&)=compass legClino(index&)=clino legFlags%(index&)=flags% ENDP PROC doOutput:(dp&) external survCount%,survName$(),sName$(),survHead%(),sNext%(),sEast(),sNorth(),sAlt(),survParent&(),legTape(),sCount% local survey%,survTrace%,station%,fullName$(255),minEast,maxEast,minNorth,maxNorth,minAlt,maxAlt,length,leg% minEast=sEast(1) :maxEast=sEast(1) minNorth=sNorth(1) :maxNorth=sNorth(1) minAlt=sAlt(1) :maxAlt=sAlt(1) lprint "Station, Easting, Northing, Height" survey%=1 :while survey%0 fullName$=survName$(survTrace%)+"."+fullName$ survTrace%=survParent&(survTrace%) endwh station%=survHead%(survey%): while station%<>0 lprint fullName$;".";sName$(station%);chr$(9); lprint fix$(sEast(station%),dp&,-12);" "; lprint fix$(sNorth(station%),dp&,-12);" "; lprint fix$(sAlt(station%),dp&,-12) if sNorth(station%)maxNorth :maxNorth=sNorth(station%) :endif if sEast(station%)maxEast :maxEast=sEast(station%) :endif if sAlt(station%)maxAlt :maxAlt=sAlt(station%) :endif station%=sNext%(station%) status: endwh rem station loop endwh rem survey loop lprint "Eastings range from ";fix$(minEast,dp&+2,14); lprint " to ";fix$(maxEast,dp&+2,14);" ("; lprint fix$(maxEast-minEast,dp&,14);"m)" lprint "Northings range from ";fix$(minNorth,dp&+2,14); lprint " to ";fix$(maxNorth,dp&+2,14);" ("; lprint fix$(maxNorth-minNorth,dp&,14);"m)" lprint "Heights range from ";fix$(minAlt,dp&+2,14); lprint " to ";fix$(maxAlt,dp&+2,14);" ("; lprint fix$(maxAlt-minAlt,dp&,14);"m)" leg%=0 :while leg%0 : s%=sNext%(s%) status: if DEBUG% :lprint "station ";sName$(s%);" (";s%;")" :endif if DEBUG% :lprint " position: ";sEast(s%);",";sNorth(s%);",";sAlt(s%) :endif if DEBUG% :lprint " flags: ";sFlags%(s%) :endif lprint sName$(s%);chr$(9); lprint fix$(sEast(s%),dp&,-12);" "; lprint fix$(sNorth(s%),dp&,-12);" "; lprint fix$(sAlt(s%),dp&,-12) if sNorth(s%)maxNorth :maxNorth=sNorth(s%) :endif if sEast(s%)maxEast :maxEast=sEast(s%) :endif if sAlt(s%)maxAlt :maxAlt=sAlt(s%) :endif if DEBUG% n% = sLegHead%(s%) while n%<>0 lprint " (";n%;") to ";sName$(legTo%(n%));": "; lprint legTape(n%),legCompass(n%), lprint legClino(n%),legFlags%(n%) n%=legFromSib%(n%) endwh n% = sRevLegHead%(s%) while n%<>0 lprint " (";n%;") from ";sName$(legFrom%(n%));": "; lprint legTape(n%),legCompass(n%), lprint legClino(n%),legFlags%(n%) n%=legToSib%(n%) endwh endif endwh endwh lprint lprint "Eastings range from ";minEast;" to ";maxEast;" (";maxEast-minEast;"m)" lprint "Northings range from ";minNorth;" to ";maxNorth;" (";maxNorth-minNorth;"m)" lprint "Heights range from ";minAlt;" to ";maxAlt;" (";maxAlt-minAlt;"m)" s%=0 :while s%3 :statusLast%=0 :endif ENDP