rem this file is "pSurvex"

rem see include file, "pSurvex.oph" for
rem compile time options

rem wish list
rem ~~~~~~~~~
rem trap errors in reading .svx files
rem deal with unconnected surveys better
rem various tidying of code
rem blank lines (fix properly and test thoroughly)
rem dynamic memory allocation
rem loop closure dispacements
rem loop lengths
rem error if output file cannot be opened
rem plot points on screen
rem rotate points on screen
rem integrated output file viewer
rem integrated text editor
rem offering to output elevation at other angles
rem speed everything up (script to inline gets and sets ?)
rem rewrite compute: and doOutput: to be less of a bodge
rem somehow try to fit in with the psion's documents scheme
rem is there someway to better parse source file
rem inline data style
rem other data styles

rem Code tidying
rem ~~~~~~~~~~~~
rem move gfx out of main into drawConsole: and call from init
rem put ini file location in header
rem write and use testFlags:
rem write and use warn:
rem write and use error:
rem write and use fatalError:
rem rename globals so they make sense

include "pSurvex.oph"
declare external
const VERSION$="pSurvex 0.23 (Beta) (Series 5)"

APP pSurvexß,&093B7073
 rem         tab ; p s
 rem FLAGS 1 rem use documents
ENDA

PROC init:
 rem Memory management stuff
 rem ~~~~~~~~~~~~~~~~~~~~~~~
 global stringTable&, nextString&, maxString&
 global surveys&, nextSurvey&, maxSurvey&
 global stations&, nextStation&, maxStation&
 global legs&, nextLeg&, maxLeg&
 rem global stackBase&,stackPtr&,stackLimit&

 rem Misc global variables
 rem ~~~~~~~~~~~~~~~~~~~~~
 global survCurrent&      rem which survey are we currently working on ?
 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..."

 stringTable& = alloc(stringALU%)
 surveys& = alloc(sizeofSurvey% * surveyALU&)
 stations& = alloc(sizeofStation% * stationALU&)
 legs& = alloc(sizeofLeg% * legALU&)
 rem stackBase& = alloc(stackALU%)

 if (stringTable&=0) or (surveys&=0) or (stations&=0) or (legs&=0) rem or (stackBase&=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&
 survCurrent& = surveys&
 nextSurvey& = surveys& + sizeofSURVEY%
 nextStation& = stations&
 nextLeg& = legs&
rem stackPtr& = stackBase&
 maxString& = stringTable& + stringALU%
 maxSurvey& = surveys& + sizeofSurvey% * surveyALU&
 maxStation& = stations& + sizeofStation% * stationALU&
 maxLeg& = legs& + sizeofLeg% * legALU&
rem stackLimit& = stackBase& + stackALU%

 zeroFlags:(survCurrent&)
 setName:(survCurrent&,"")
 setParent:(survCurrent&,NULL%)
 setDaughter:(survCurrent&,NULL%)
 setSister:(survCurrent&,NULL%)
 setStationHead:(survCurrent&,NULL%)
 setStationTail:(survCurrent&,NULL%)
 setTapeCalib:(survCurrent&,0)
 setCompassCalib:(survCurrent&,0)
 setClinoCalib:(survCurrent&,0)

 screen 88,12
 main:
ENDP

PROC main:
 external DEBUG%,surveys&
 global directory$(255)
 local file$(255),off%(6),places&,fIni%,error%
 places&=2
 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
 cls
 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 "+fix$(error%,0,3)+", ";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 "+fix$(error%,0,3)+", ";err$(error%);" writing to .ini file"
 endif
 ioclose(fIni%)
 parse$(file$,"",off%())
 directory$=left$(file$,off%(4)-1)
 lopen left$(file$,off%(5)-1)+".pos.txt"
 rem FIXME - need to notice if fail to open above file
 rem         since nothing gets written if it is already open 
 print "Warning: no error raised or output generated if "+left$(file$,off%(5)-1)+".pos.txt is already open"
 readFile:(file$)
 statusText:("Computing...")
 compute:
 statusText:("Writing positions to file...")
 doOutput:(places&)
 beep 8,300
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%),lc%
 local fin%, err%, ptr&
 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%) 
     lc%=lc%+1
     if (err% >= 0)
       pokeb ptr&,err%
       statusText:("parsing line "+fix$(lc%,0,4)+" in "+filename$)
       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 file ";filename$  
     endif
   endwh
 endif
ENDP

rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rem This procedure takes a line and decides what to do
rem with it then passes to the appropriate procedure
rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PROC parseLine:
 external line$   rem the line defined as global from readFile:
 external DEBUG%,survCurrent&
 global count%    rem how many characters in we are (for nextToken:)
 local token$(LINELENGTH%)
 if DEBUG% :print line$ :endif
 token$=nextToken$:
 if token$=""
   rem noop
 elseif asc(mid$(token$,1,1))=%*
   token$=upper$(token$)
   @("parse"+(mid$(token$,2,len(token$)))):
   rem FIXME - this may be neat but it doesn't generate
   rem         a very nice error if the procedure doesn't
   rem         exist.
 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
    if count%>len(line$): chAsc%=0 :break :endif
    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
  return token$
ENDP

rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rem this procedure takes two station names and
rem data adds the leg to 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

PROC setLeg:(leg&,tape,compass,clino,flags%)
  pokef leg&+OFFtape%,tape
  pokef leg&+OFFcompass%,compass
  pokef leg&+OFFclino%,clino
  setFlags:(leg&,flags%)
ENDP

rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rem This creates and returns the address of a
rem new blank entry in the leg structure for
rem given station addresses
rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PROC newLeg&:(from&,to&)
  external nextLeg&,maxLeg&,stations&,nextStation&,survCurrent&
  local node&,test$(LINELENGTH%)
  if (to&<stations&) or (to&>nextStation&) or (from&<stations&) or (from&>nextStation&)
    print
    print "   *** INTERNAL ERROR ***    "
    print " tried to create a leg to or "
    print " from an invalid station     "
    print
  endif
  if nextLeg&>maxLeg&
    reallocLegs:
  endif
  setFrom:(nextLeg&,from&)
  setTo:(nextLeg&,to&)
  setFromSister:(nextLeg&,NULL%)
  setToSister:(nextLeg&,NULL%)
  zeroFlags:(nextLeg&)
  setFlags:(nextLeg&,getFlags%:(survCurrent&))
  if getLegHead&:(from&)=NULL%
    setLegHead:(from&,nextLeg&)
  else
    node& = getLegHead&:(from&)
    while getFromSister&:(node&)<>NULL%
      node& = getFromSister&:(node&)
    endwh
    setFromSister:(node&,nextLeg&)
  endif
  if getBacklegHead&:(to&)=NULL%
    setBacklegHead:(to&,nextLeg&)
  else
    node& = getBacklegHead&:(to&)
    while getToSister&:(node&)<>NULL%
      node& = getToSister&:(node&)
    endwh
    setToSister:(node&,nextLeg&)
  endif
  nextLeg&=nextLeg&+sizeofLEG%
  return nextLeg&-sizeofLEG%
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&:(sName$)
  external survCurrent&, nextStation&, maxStation&
  local stat&,surv&,subSurvey$(LINELENGTH%),name$(LINELENGTH%)
  name$=sName$
  surv&=survCurrent&
  while loc(name$,".")<>0  
    subSurvey$=left$(name$,loc(name$,".")-1)
    name$=right$(name$,len(name$)-loc(name$,"."))
    surv&=getSurvey&:(subSurvey$,surv&)
  endwh
  stat&=getStationHead&:(surv&)
  while stat&<>NULL%
    if upper$(getName$:(stat&))=upper$(name$)
      break
    endif
    stat&=getNext&:(stat&)
  endwh
  if stat&=NULL%
    if nextStation&>maxStation&
      reallocStations:
    endif
    stat&=nextStation&
    nextStation&=nextStation&+sizeofSTATION%
    setName:(stat&,name$)
    zeroFlags:(stat&)
    setInSurvey:(stat&,surv&)
    setNext:(stat&,NULL%)
    setLegHead:(stat&,NULL%)
    setBacklegHead:(stat&,NULL%)
    setEast:(stat&,0)
    setNorth:(stat&,0)
    setHeight:(stat&,0)
    if getStationHead&:(surv&)=NULL%
      setStationHead:(surv&,stat&)
    else
      setNext:(getStationTail&:(surv&),stat&)
    endif
    setStationTail:(surv&,stat&)
  endif
  return stat&
ENDP

PROC getSurvey&:(name$,root&)
  external survCurrent&,nextSurvey&,maxSurvey&
  local surv&
  surv&=getDaughter&:(root&)
  while surv&<>NULL%
    if upper$(getName$:(surv&))=upper$(name$)
      break
    endif
    surv&=getSister&:(surv&)
  endwh
  if surv&=NULL%
    if nextSurvey&>maxSurvey&
      reallocSurveys:
    endif
    setParent:(nextSurvey&,root&)
    surv&=getDaughter&:(root&)
    if surv& = NULL%
      setDaughter:(root&,nextSurvey&)
    else
      while getSister&:(surv&)<>NULL%
        surv&=getSister&:(surv&)
      endwh
      setSister:(surv&,nextSurvey&)
    endif
    surv&=nextSurvey&
    nextSurvey&=nextSurvey&+sizeofSURVEY%
    setName:(surv&,name$)
    zeroFlags:(surv&)
    setFlags:(surv&,getFlags%:(root&))
    setDaughter:(surv&,NULL%)
    setSister:(surv&,NULL%)
    setStationHead:(surv&,NULL%)
    setStationTail:(surv&,NULL%)
    setTapeCalib:(surv&,0)     rem FIXME - should these be
    setCompassCalib:(surv&,0)  rem         inherited from
    setClinoCalib:(surv&,0)    rem         parent survey ?
  endif
  return surv&
ENDP

rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rem This procedure traverses the tree and
rem computes the survey
rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PROC compute:
 rem this is quick and dirty
 external DEBUG%,stations&,nextStation&
 local dE,dN,dH,tape,compass,clino
 local stat&, stat2&, leg&, changes%
 stat&=stations&-sizeofSTATION% :while stat&<nextStation&-sizeofSTATION% :stat&=stat&+sizeofSTATION%
   if (getFlags%:(stat&) and flagCALC%) = flagCALC%
     changes%=-1
     break
   endif
 endwh 
 if changes%<>-1
   setFlags:(stations&,flagCALC%)
   print "WARNING: no fixed points, fixing station ";getName$:(stations&);" to 0,0,0"
 endif
 changes%=1 :while changes%=1 :changes%=0
   stat&=stations&-sizeofSTATION% :while stat&<nextStation&-sizeofSTATION% :stat&=stat&+sizeofSTATION%
     status:
     if (getFlags%:(stat&) and flagCALC%) = flagCALC%
       leg&=getLegHead&:(stat&)
       while leg&<>NULL%
         stat2&=getTo&:(leg&)
         if (getFlags%:(stat2&) and flagCALC%) <> flagCALC%
           rem can't do loop closures this way !
           tape=getTape:(leg&)
           compass=rad(getCompass:(leg&))
           clino=rad(getClino:(leg&))
           dE=sin(compass)*cos(clino)*tape
           dN=cos(compass)*cos(clino)*tape
           dH=sin(clino)*tape
           setEast:(stat2&,getEast:(stat&)+dE)
           setNorth:(stat2&,getNorth:(stat&)+dN)
           setHeight:(stat2&,getHeight:(stat&)+dH)
           setFlags:(stat2&,flagCALC%)
           changes%=1
         endif
         leg&=getFromSister&:(leg&)
       endwh
       leg&=getBacklegHead&:(stat&)
       while leg&<>NULL%
         stat2&=getFrom&:(leg&)
         if (getFlags%:(stat2&) and flagCALC%) <> flagCALC%
           tape=getTape:(leg&)
           compass=rad(getCompass:(leg&)+180)
           clino=rad(getClino:(leg&)*-1)
           dE=sin(compass)*cos(clino)*tape
           dN=cos(compass)*cos(clino)*tape
           dH=sin(clino)*tape
           setEast:(stat2&,getEast:(stat&)+dE)
           setNorth:(stat2&,getNorth:(stat&)+dN)
           setHeight:(stat2&,getHeight:(stat&)+dH)
           setFlags:(stat2&,flagCALC%)
           changes%=1
         endif
         leg&=gettoSister&:(leg&)
       endwh
     endif
   endwh
 endwh
ENDP

PROC doOutput:(dp&)
  external surveys&,nextSurvey&,stations&,nextStation&,legs&,nextLeg&
  local survey&,survTrace&,station&,leg&,fullName$(255)
  local east, north, height
  local minEast,maxEast,minNorth,maxNorth,minHeight,maxHeight
  local surfLength,ugLength,totalSurfLength,totalUgLength
  minEast=getEast:(stations&)
  minNorth=getNorth:(stations&)
  minHeight=getHeight:(stations&)
  station&=stations&-sizeofSTATION% :while station&<nextStation&-sizeofSTATION% :station&=station&+sizeofSTATION%
    if (getFlags%:(station&) and flagCALC%) = flagCALC%
      minEast=getEast:(station&)
      minNorth=getNorth:(station&)
      minHeight=getHeight:(station&)
      break
    endif
  endwh
  maxEast=minEast
  maxNorth=minNorth
  maxHeight=minHeight
  lprint "Generated by ";VERSION$;" ";datim$
  lprint
  lprint "Station, Easting, Northing, Height"
  survey&=surveys&-sizeofSURVEY% :while survey&<nextSurvey&-sizeofSURVEY% :survey&=survey&+sizeofSURVEY%
    fullName$=getName$:(survey&)
    survTrace&=getParent&:(survey&)
    if survTrace&<>NULL%
      while getParent&:(survTrace&)<>NULL%
        fullName$=getName$:(survTrace&)+"."+fullName$
        survTrace&=getParent&:(survTrace&)
      endwh
    endif
    station&=getStationHead&:(survey&)
    while station&<>NULL%
      east = getEast:(station&)
      north = getNorth:(station&)
      height = getHeight:(station&)
      lprint fullName$;".";getName$:(station&);chr$(9);
      lprint fix$(east,dp&,-14);"  ";
      lprint fix$(north,dp&,-14);"  ";
      lprint fix$(height,dp&,-14)
      if north<minNorth :minNorth=north :endif
      if north>maxNorth :maxNorth=north :endif
      if east<minEast :minEast=east :endif
      if east>maxEast :maxEast=east :endif
      if height<minHeight :minHeight=height :endif
      if height>maxHeight :maxHeight=height :endif
      station&=getNext&:(station&)
      status:
    endwh rem station loop
  endwh rem survey loop
  lprint
  lprint "Eastings range from ";fix$(minEast,dp&+2,16);
  lprint " to ";fix$(maxEast,dp&+2,16);" (";
  lprint fix$(maxEast-minEast,dp&,16);"m)"
  lprint "Northings range from ";fix$(minNorth,dp&+2,16);
  lprint " to ";fix$(maxNorth,dp&+2,16);" (";
  lprint fix$(maxNorth-minNorth,dp&,16);"m)"
  lprint "Heights range from ";fix$(minHeight,dp&+2,16);
  lprint " to ";fix$(maxHeight,dp&+2,16);" (";
  lprint fix$(maxHeight-minHeight,dp&,16);"m)"
  lprint
  lprint "Survey lengths (excluding sub-surveys)"
  lprint "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
  survey&=surveys&-sizeofSURVEY% :while survey&<nextSurvey&-sizeofSURVEY% :survey&=survey&+sizeofSURVEY%
    status:
    leg&=legs&-sizeofLEG% :while leg&<nextLeg&-sizeofLEG% :leg&=leg&+sizeofLEG%
      if getInSurvey&:(getFrom&:(leg&))=survey&
        if getFlags%:(leg&) and flagSURFACE% = flagSURFACE%
          surfLength=surfLength+getTape:(leg&)
        else
          ugLength=ugLength+getTape:(leg&)
        endif
      endif
    endwh
    fullName$=getName$:(survey&)
    survTrace&=getParent&:(survey&)
    if survTrace&<>NULL%
      while getParent&:(survTrace&)<>NULL%
        fullName$=getName$:(survTrace&)+"."+fullName$
        survTrace&=getParent&:(survTrace&)
      endwh
    else
      fullName$="root survey"
    endif
    lprint fullName$;" (surface) : ";fix$(surfLength,dp&+2,16);"m"
    lprint fullName$;" (underground) : ";fix$(ugLength,dp&+2,16);"m"
    totalSurfLength=totalSurfLength+surfLength
    totalUgLength=totalUgLength+ugLength
    surfLength=0 :ugLength=0
  endwh
  lprint
  lprint "Surface survey length: ";fix$(totalSurfLength,dp&+2,16);"m"
  lprint "Underground survey length: ";fix$(totalUgLength,dp&+2,16);"m"
  lprint "Total survey length: ";fix$(totalSurfLength+totalUgLength,dp&+2,16);"m"
ENDP

PROC reallocLegs:
  print
  print "Dynamic memory not yet implemented"
  print "increase legALU& in pSurvex.h and recompile"
  print :get :stop
ENDP

PROC reallocStations:
  print
  print "Dynamic memory not yet implemented"
  print "increase statonALU& in pSurvex.h and recompile"
  print :get :stop
ENDP

PROC reallocSurveys:
  print
  print "Dynamic memory not yet implemented"
  print "increase surveyALU& in pSurvex.h and recompile"
  print :get :stop
ENDP

PROC reallocStringTable:(min%)
  print
  print "Dynamic memory not yet implemented"
  print "increase stringALU% in pSurvex.h and recompile"
  print :get :stop
ENDP

PROC stackOverflow:
  print
  print "Stack Overflow"
  print "increase stackALU% in pSurvex.h and recompile"
  print :get :stop
ENDP

PROC pushw:(w%)
  external stackBase&,stackPtr&,stackLimit&
  if stackPtr&+sizeofInt%>stackLimit& :stackOverflow: :endif
  pokew stackPtr&,w%
  stackPtr&=stackPtr&+sizeofInt%
ENDP

PROC pushl:(l&)
  external stackBase&,stackPtr&,stackLimit&
  if stackPtr&+sizeofLong%>stackLimit& :stackOverflow: :endif
  pokew stackPtr&,l&
  stackPtr&=stackPtr&+sizeofLong%
ENDP

PROC pushf:(f)
  external stackPtr&,stackLimit&
  if stackPtr&+sizeofFloat%>stackLimit& :stackOverflow: :endif
  pokew stackPtr&,f
  stackPtr&=stackPtr&+sizeofFloat%
ENDP

PROC popw%:
  external stackPtr&,stackBase&
  stackPtr&=stackPtr&-sizeofInt%
  if stackPtr&<stackBase& :internalError:("Stack fault") :endif
  return(peekw(stackPtr&))
ENDP

PROC popl&:
  external stackPtr&,stackBase&
  stackPtr&=stackPtr&-sizeofLong%
  if stackPtr&<stackBase& :internalError:("Stack fault") :endif
  return(peekl(stackPtr&))
ENDP

PROC popf:
  external stackPtr&,stackBase&
  stackPtr&=stackPtr&-sizeofFloat%
  if stackPtr&<stackBase& :internalError:("Stack fault") :endif
  return(peekf(stackPtr&))
ENDP

PROC statusText:(text$)
 external blankLine$
 gat 1,20 :gprintb text$,600
ENDP

PROC status:
  external statusLast%,screenWidth%
  local ev&(16)
  gat 620,20
  vector statusLast%+1
   a, b, c, d
  endv
   a:: gprintb "-",20 :goto done
   b:: gprintb "\",20 :goto done
   c:: gprintb "|",20 :goto done
   d:: gprintb "/",20 :goto done
  done::
  if testevent
   getevent32 ev&()
   if ev&(1) = $404
     if left$(getcmd$,1)="X"
      cls
      print "closing..."
      stop           rem dirty hack
     endif
   endif
  endif
  statusLast%=statusLast%+1
  if statusLast%>3 :statusLast%=0 :endif
ENDP

PROC printStation:(stat&)
  if stat&=NULL%
    print "station is NULL"
  else
    print "station ";stat&;" is ";getName$:(stat&)
    print "flags: ";getFlags%:(stat&);
    print " survey is ";getInSurvey&:(stat&)
    print "next is ";getNext&:(stat&);
    print " legHead is ";getLegHead&:(stat&)
    print "backlegHead is ";getBacklegHead&:(stat&)
  endif
  get
ENDP

PROC printLeg:(leg&)
  if leg&=NULL%
    print "Leg is NULL"
  else
    print "Leg ";leg&;" flags:";getFlags%:(leg&)
    print "from ";getFrom&:(leg&);
    print " fromSister ";getFromSister&:(leg&)
    print "to ";getTo&:(leg&);
    print " toSister ";getToSister&:(leg&)
  endif
  get
ENDP

PROC parseData:(token1$)
 external DEBUG%,survCurrent&
 local token$(LINELENGTH%), from$(LINELENGTH%), to$(LINELENGTH%), tape, compass, clino
 from$ = token1$
 to$ = nextToken$:
 tape = val(nextToken$:)
 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.5)
       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
 if compass=999
   addleg:(from$,to$,tape+getTapeCalib:(survCurrent&),999,clino,0)
 else
   addleg:(from$,to$,tape+getTapeCalib:(survCurrent&),compass+getCompassCalib:(survCurrent&),clino+getClinoCalib:(survCurrent&),0)
 endif
ENDP

PROC parseBegin:
  external survCurrent&
  local newSurvey$(LINELENGTH%)
  newSurvey$ = nextToken$:
  survCurrent&=getSurvey&:(newSurvey$,survCurrent&)
ENDP

PROC parseEnd:
  external survCurrent&,surveys&
  local token$(LINELENGTH%)
  token$=nextToken$:
  if survCurrent&=surveys&
    print "Warning *END "; token$; " in root survey"
  elseif upper$(token$)<>upper$(getName$:(survCurrent&))
    print "Warning expecting *END "; getName$:(survCurrent&); " got *END "; token$
  else
    survCurrent&=getParent&:(survCurrent&)
  endif
ENDP

PROC parseFix:
  external DEBUG%
  local statName$(LINELENGTH%),stat&,east,north,height
  statName$=nextToken$:
  stat&=getStation&:(statName$)
  pokef stat&+OFFeast%,val(nextToken$:)
  pokef stat&+OFFnorth%,val(nextToken$:)
  pokef stat&+OFFheight%,val(nextToken$:)
  setFlags:(stat&,flagCALC%)
ENDP

PROC parseEquate:
  external DEBUG%
  local from$(LINELENGTH%),to$(LINELENGTH%)
  from$ = nextToken$:
  to$ = nextToken$:
  addleg:(from$,to$,0,888,0,0)
ENDP

PROC parseInclude:
  external directory$
  readFile:(directory$+nextToken$:)
ENDP

PROC parseExport:
ENDP

PROC parseFlags:
  external survCurrent&,lc%
  local token$(LINELENGTH%),flag%,not%
  not%=FALSE%
  flag%=0
  token$=upper$(nextToken$:)
  while token$<>""
    if token$="NOT"
      if not%=true%
        print "Warning: ignoring double negative in *FLAGS on line ";lc%
      endif
      not%=TRUE%
    else
      if token$="SURFACE": flag%=flagSURFACE%
      elseif token$="SPLAY": flag%=flagSPLAY%
      elseif token$="DUPLICATE": flag%=flagDUPLICATE%
      else
        print "Warning: *FLAGS (NOT)";token$;" not recognised"
      endif
      if not%=TRUE%
        unsetFlags:(survCurrent&,flag%)
      else
        setFlags:(survCurrent&,flag%)
      endif
      not%=FALSE%
      flag%=0
    endif
    token$=upper$(nextToken$:)
  endwh
  if not%=TRUE%
    print "Warning: *FLAGS ends with a NOT on line ";lc%
  endif
ENDP

PROC parseCalibrate:
  external survCurrent&,lc%
  local what$(linelength%),amount
  what$=upper$(nextToken$:)
  amount=val(nextToken$:)
  if nextToken$:<>""
    print "Error: can only calibrate one thing at once (line ";lc%;")"
  endif
  if what$="TAPE"
    setTapeCalib:(survCurrent&,amount)
  elseif what$="COMPASS"
    setCompassCalib:(survCurrent&,amount)
  elseif what$="CLINO"
    setClinoCalib:(survCurrent&,amount)
  else
    print "Error: cannot calibrate a ";what$; "(line ";lc%;")"
  endif
ENDP

PROC parseTeam:
ENDP

PROC parseDate:
ENDP

PROC parseTitle:
ENDP

PROC parseEntrance:
ENDP

PROC parseInstrument:     rem FIXME - which one is valid ?
ENDP

PROC parseInstruments:    rem FIXME - which one is valid ?
ENDP


rem parameters for both surveys and stations
rem ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PROC getFlags%:(s&)
  return peekw(s&+OFFflags%)
ENDP

PROC setFlags:(s&,flags%)
  pokew s&+OFFflags%,(peekw(s&+OFFflags%) or flags%)
ENDP

PROC unsetFlags:(s&,flags%)
  pokew s&+OFFflags%,(peekw(s&+OFFflags%) and not(flags%))
ENDP

PROC zeroFlags:(s&)
  pokew s&+OFFflags%,0
ENDP

PROC getName$:(s&)
  return peek$(peekl(s&+OFFname%))
ENDP

PROC setName:(s&,name$)
  external nextString&,maxString&
  if nextString&+len(name$)+1 > maxString&
    reallocStringTable:(len(name$)+1)
  endif
  pokel s&+OFFname%,nextString&
  poke$ nextString&,name$
  nextString&=nextString&+len(name$)+1
ENDP

rem parameters for surveys
rem ~~~~~~~~~~~~~~~~~~~~~~
PROC getParent&:(survey&)
  return peekl(survey&+OFFparent%)
ENDP

PROC setParent:(survey&,parent&)
  pokel survey&+OFFparent%,parent&
ENDP

PROC getDaughter&:(survey&)
  return peekl(survey&+OFFdaughter%)
ENDP

PROC setDaughter:(survey&,daughter&)
  pokel survey&+OFFdaughter%,daughter&
ENDP

PROC getSister&:(survey&)
  return peekl(survey&+OFFsister%)
ENDP

PROC setSister:(survey&,sister&)
  pokel survey&+OFFsister%,sister&
ENDP

PROC getStationHead&:(survey&)
  return peekl(survey&+OFFstationHead%)
ENDP

PROC setStationHead:(survey&,stationHead&)
  pokel survey&+OFFstationHead%,stationHead&
ENDP

PROC getStationTail&:(survey&)
  return peekl(survey&+OFFstationTail%)
ENDP

PROC setStationTail:(survey&,stationTail&)
  pokel survey&+OFFstationTail%,stationTail&
ENDP

PROC getTapeCalib:(survey&)
  return peekf(survey&+OFFtapeCalib%)
ENDP

PROC setTapeCalib:(survey&,tapeCalib)
  pokef survey&+OFFtapeCalib%,tapeCalib
ENDP

PROC getCompassCalib:(survey&)
  return peekf(survey&+OFFcompassCalib%)
ENDP

PROC setCompassCalib:(survey&,compassCalib)
  pokef survey&+OFFcompassCalib%,compassCalib
ENDP

PROC getClinoCalib:(survey&)
  return peekf(survey&+OFFclinoCalib%)
ENDP

PROC setClinoCalib:(survey&,clinoCalib)
  pokef survey&+OFFclinoCalib%,clinoCalib
ENDP

rem Station parameters
PROC getInSurvey&:(station&)
  return peekl(station&+OFFsurvey%)
ENDP

PROC setInSurvey:(station&,survey&)
  pokel station&+OFFsurvey%,survey&
ENDP

PROC getNext&:(station&)
  return peekl(station&+OFFnext%)
ENDP

PROC setNext:(station&,next&)
  pokel station&+OFFnext%,next&
ENDP

PROC getLegHead&:(station&)
  return peekl(station&+OFFlegHead%)
ENDP

PROC setLegHead:(station&,legHead&)
  pokel station&+OFFlegHead%,legHead&
ENDP

PROC getBacklegHead&:(station&)
  return peekl(station&+OFFbacklegHead%)
ENDP

PROC setBacklegHead:(station&,backlegHead&)
  pokel station&+OFFbacklegHead%,backlegHead&
ENDP

PROC getEast:(station&)
  return peekf(station&+OFFeast%)
ENDP

PROC setEast:(station&,east)
  pokef station&+OFFeast%,east
ENDP

PROC getNorth:(station&)
  return peekf(station&+OFFNorth%)
ENDP

PROC setNorth:(station&,north)
  pokef station&+OFFnorth%,north
ENDP

PROC getHeight:(station&)
  return peekf(station&+OFFheight%)
ENDP

PROC setHeight:(station&,height)
  pokef station&+OFFheight%,height
ENDP

rem parameters for legs
rem ~~~~~~~~~~~~~~~~~~~
PROC getFrom&:(leg&)
  return peekl(leg&+OFFfrom%)
ENDP

PROC setFrom:(leg&,from&)
  pokel leg&+OFFfrom%,from&
ENDP

PROC getFromSister&:(leg&)
  return peekl(leg&+OFFfromSister%)
ENDP

PROC setFromSister:(leg&,sister&)
  pokel leg&+OFFfromSister%,sister&
ENDP

PROC getTo&:(leg&)
  return peekl(leg&+OFFto%)
ENDP

PROC setTo:(leg&,to&)
  pokel leg&+OFFto%,to&
ENDP

PROC getToSister&:(leg&)
  return peekl(leg&+OFFtoSister%)
ENDP

PROC setToSister:(leg&,sister&)
  pokel leg&+OFFtoSister%,sister&
ENDP

PROC getTape:(leg&)
  return peekf(leg&+OFFtape%)
ENDP

PROC setTape:(leg&,tape)
  pokef leg&+OFFtape%,tape
ENDP

PROC getCompass:(leg&)
  return peekf(leg&+OFFcompass%)
ENDP

PROC setCompass:(leg&,compass)
  pokef leg&+OFFcompass%,compass
ENDP

PROC getClino:(leg&)
  return peekf(leg&+OFFclino%)
ENDP

PROC setClino:(leg&,clino)
  pokef leg&+OFFclino%,clino
ENDP