7m…ôcUT\cd“™rem this file is "pSurvex-6-14"rem see include file, "pSurvex.oph" forrem compile time optionsrem wish listrem ~~~~~~~~~remrem offering to plot elevation anglerem sub surveysrem *calibraterem *equaterem *includerem trap errors in reading .svx filesrem - and print line numbersrem allow > 500 stations (hack)rem allow > 500 stations (rewrite)rem blank linesrem allow longer survey namesrem error if output file cannot be openedrem integrated output file viewerrem integrated text editor include "pSurvex.oph"declare externalconst VERSION$="pSurvex 0.10 (beta) (Series 5)"APP pSurvex,&093B7073 rem tab ; p s rem FLAGS 1 rem use documentsENDAPROC 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 now do something with ... rem ~~~~~~~~~~~~~~~~~~~~~~~~~ print VERSION$; " initialising..." sMax% = ALU% legMax% = ALU% survMax% = 40 rem FIXME survCurrent% = 1 survCount% = 1 screen 88,12 main:ENDPPROC 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&)ENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem This procedure takes a filename and passesrem it line by line to the parser. Welcome torem 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 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 endifENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem This procedure will ultimately reallocaterem memory when we run out of room in the treerem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~PROC growTree: rem reallocate sn*() to snMax+=ALU or die print "out of memory error (limited to "; ALU%; " stations at the moment)" get stopENDPPROC 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$) endifENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem this procedure looks at line$ andrem returns the next token from therem count%+1 character and advances count%rem to the last character in the tokenrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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$ENDPPROC 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)ENDPPROC parseBegin: external line$, count%, survParent%(), survCurrent%, survName$(), survMax%, survCount% local newSurvey$(LINELENGTH%), surv% newSurvey$ = nextToken$: survCurrent%=getSurvey:(newSurvey$,survCurrent%)ENDPPROC 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%ENDPPROC 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%) endifENDPPROC 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%ENDPPROC parseEquate: external line$, count% local from$(LINELENGTH%),to$(LINELENGTH%) from$ = nextToken$: to$ = nextToken$: addleg:(from$,to$,0,888,0,0)ENDPPROC parseInclude: external line$, count% cls print "ERROR*INCLUDE unimplemented at present" get stopENDPPROC parseExport: external line$, count%ENDPPROC 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%=-1rem elserem if token$="SURFACE": flag%=flagSURFACE%rem elserem print "Flag "+token$+" not recognised"rem endifrem if off%rem survFlags%(thisSurv%)=survFlags%(thisSurv%) and not(flag%)rem elserem survFlags%(thisSurv%)=survFlags%(thisSurv%) or flag%rem endifrem endifrem token$=upper$(nextToken$:)rem endwhENDPPROC parseTeam: external line$, count% rem print "parseTeam"ENDPPROC parseCalibrate: external line$, count% rem print "parseCalibrate"ENDPPROC parseDate: external line$, count% rem print "parseDate"ENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem this procedure takes data and adds it torem the tree.rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~PROCaddLeg:(from$, to$, tape, compass, clino, flags%) local fromStation%, toStation%, leg% local toNode%, fromNode% fromStation% = getStation:(from$) toStation% = getStation:(to$) leg% = newLeg:(fromStation%,toStation%) setleg:(leg%, tape, compass, clino, flags%)ENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem This procedure traverses the tree andrem computes the surveyrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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 :endifrem 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;" " :endifrem if DEBUG% :print :get :endif sFlags%(s2%)=sFlags%(s2%) or flagCALC% changes%=1 endif leg%=legToSib%(leg%) endwh  endif endwh endwhENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem This creates and returns the index of arem new blank entry in the leg structurerem for given station indicesrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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%ENDPrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~rem This returns the station index for arem given station name, creating one if itrem the station name isn't found amongstrem those listedrem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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%ENDPPROC setLeg:(index%,tape,compass,clino,flags%) external legTape(), legCompass(), legClino(), legFlags%() legTape(index%)=tape legCompass(index%)=compass legClino(index%)=clino legFlags%(index%)=flags%ENDPPROC 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$;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%) endwh rem station loop endwh rem survey loop 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)" 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 :endifENDPÐР   \cZSefd\cbSefdý‚.ÆA…*TextEd.app…jS‰ñS