home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 1 / ARM_CLUB_CD.iso / contents / pktbook / progs / programs17 / OPL / FSORT_OPL < prev    next >
Encoding:
Text File  |  1994-10-13  |  6.2 KB  |  302 lines
  1. rem app FSort
  2. rem    ext "XYZ"
  3. rem    icon "A:\PIC\FSORT.PIC"
  4. rem enda
  5.  
  6. proc FSort:
  7.     global a$(901,32),path$(128)
  8.     global bPath$(128),nr%,max%
  9.     local p%,e%,id%
  10.     giPrint swver$:
  11.     init:
  12.     max%=900
  13.     while getFile:
  14.         p%=1
  15.         id%=progress:("Sorting data...",-1,0)
  16.         first
  17.         while not eof
  18.             inSort:(valid$:,p%)
  19.             next
  20.             p%=p%+1
  21.             if mod%:(p%,10)=0
  22.                 progress:("",p%,nr%*2)
  23.             endif
  24.         endwh
  25.         copyFile:
  26.         progress:("",nr%*2,nr%*2)
  27.         progress:("",-2,id%)
  28.         signal:
  29.         dInit "Sort completed"
  30.         dPosition 1,-1
  31.         dText "Press:","ENTER to continue"
  32.         dText " ","ESC to quit"
  33.         lock on :e%=Dialog :lock off
  34.         if e%=0 :stop :endif
  35.     endwh
  36. endp
  37.  
  38. proc copyFile:
  39.     local p%,e%,tPath$(128),f%(6)
  40.     progress:("Setting up new file...",nr%,nr%*3)
  41.     trap close
  42.     tPath$=left$(path$,len(path$)-1)+""
  43.     trap delete tPath$
  44.     compress path$,tPath$
  45.     open  path$,a,a$,b$,c$,d$,e$,f$,g$,h$,i$,j$,k$,l$,m$,n$,o$,p$
  46.     open tPath$,b,a$,b$,c$,d$,e$,f$,g$,h$,i$,j$,k$,l$,m$,n$,o$,p$
  47.     p%=nr% :e%=1
  48.     while p%<>0
  49.         last :erase :p%=p%-1 :e%=e%+1
  50.         if mod%:(p%,10)=0
  51.             progress:("",nr%+e%,nr%*3)
  52.         endif
  53.     endwh
  54.     progress:("Writing sorted data",nr%*2,nr%*3)
  55.     p%=1
  56.     while p%<=nr%
  57.         e%=val(left$(a$(p%),3))
  58.         use a :position e%
  59.         b.a$=a.a$ :b.b$=a.b$ :b.c$=a.c$
  60.         b.d$=a.d$ :b.e$=a.e$ :b.f$=a.f$
  61.         b.g$=a.g$ :b.h$=a.h$ :b.i$=a.i$
  62.         b.j$=a.j$ :b.k$=a.k$ :b.l$=a.l$
  63.         b.m$=a.m$ :b.n$=a.n$ :b.o$=a.o$
  64.         b.p$=a.p$
  65.         use b :append
  66.         p%=p%+1
  67.         if mod%:(p%,10)=0
  68.             progress:("",(nr%*2)+p%,nr%*3)
  69.         endif
  70.     endwh
  71.     trap use a :trap close
  72.     trap use b :trap close
  73.     trap delete bPath$
  74.     rename path$,bPath$
  75.     rename tPath$,path$
  76. endp
  77.  
  78. proc init:
  79.     gStyle 1+8+32
  80.     gAT 15,19 :gPrint "F S o r t"
  81.     gStyle 0
  82.     gAT 140,16
  83.     gPrint "Version",left$(swver$:,loc(swver$:," "))
  84.     gAT 0,26
  85.     gBorder $201,240,54
  86.     gAT 8,38 :gPrint "Original file:"
  87.     gAT 8,57 :gPrint "Backup file:"
  88. endp
  89.  
  90. proc info:(s$)
  91.     local b$(11)
  92.     busy off
  93.     b$="...empty..."
  94.     dInit s$
  95.     if a.a$="" :dText "",b$
  96.     else :dText "",left$(a.a$,40) :endif
  97.     if a.b$="" :dText "",b$
  98.     else :dText "",left$(a.b$,40) :endif
  99.     if a.c$="" :dText "",b$
  100.     else :dText "",left$(a.c$,40) :endif
  101.     if a.d$="" :dText "",b$
  102.     else :dText "",left$(a.d$,40) :endif
  103.     if a.e$="" :dText "",b$
  104.     else :dText "",left$(a.e$,40) :endif
  105.     lock on :Dialog :lock off
  106. endp
  107.  
  108. proc getFile:
  109.     local e%,r%,a%(6),s&
  110.     START::
  111.     lock off :s&=0 :trap close
  112.     path$=parse$(path$,"\DAT\*.DBF",a%())
  113.     dInit "File to sort"
  114.     dFile path$,"",0    
  115.     dPosition 1,-1
  116.     lock on
  117.     if dialog
  118.         rem Check file type, etc.
  119.         trap openr path$,a,a$,b$,c$,d$,e$,f$,g$,h$,i$,j$,k$,l$,m$,n$,o$,p$
  120.         if err
  121.             giPrint err$(err)
  122.             goto START::
  123.         endif
  124.         nr%=count
  125.         if nr%>max%
  126.             trap close
  127.             giPrint "Too many records"
  128.             goto START::
  129.         endif
  130.         busy "Checking file...",2,0
  131.         onerr OUT::
  132.         first
  133.         while not eof
  134.             rem If there's data in the 16th
  135.             rem field, it's likely that the
  136.             rem 17th does too. Better safe...
  137.             if a.p$<>""
  138.                 info:("This record may be too large")
  139.              goto START::
  140.             endif
  141.             s&=s&+recsize
  142.             next
  143.         endwh
  144.         if s&+1000>space
  145.             giPrint "Not enough space"
  146.             goto START::
  147.         endif
  148.         onerr off :busy off :lock off
  149.         bPath$=left$(path$,len(path$)-1)+"!"
  150.         gAT 10,48 :gPrintB path$,220,3
  151.         gAT 10,65 :gPrintB bPath$,220,3
  152.         gAT 10,75 :gPrintB "Check original before deleting backup",220,3
  153.         return 1
  154.     else
  155.         lock off :return 0
  156.     endif
  157.     
  158.     OUT::
  159.     onerr off
  160.     trap close
  161.     giPrint "Record too large"
  162.     giprint err$(err)
  163.     goto START::
  164. endp
  165.  
  166. proc valid$:
  167.     rem    Returns a valid string (field)
  168.     rem    from the current record for
  169.     rem sorting: upper case, 1..29
  170.     rem characters in length
  171.     if a.a$<>""
  172.         return upper$(left$(a.a$,29))
  173.     elseif a.b$<>""
  174.         return upper$(left$(a.b$,29))
  175.     elseif a.c$<>""
  176.         return upper$(left$(a.c$,29))
  177.     elseif a.d$<>""
  178.         return upper$(left$(a.d$,29))
  179.     elseif a.e$<>""
  180.         return upper$(left$(a.e$,29))
  181.     elseif a.f$<>""
  182.         return upper$(left$(a.f$,29))
  183.     elseif a.g$<>""
  184.         return upper$(left$(a.g$,29))
  185.     elseif a.h$<>""
  186.         return upper$(left$(a.h$,29))
  187.     elseif a.i$<>""
  188.         return upper$(left$(a.i$,29))
  189.     elseif a.j$<>""
  190.         return upper$(left$(a.j$,29))
  191.     elseif a.k$<>""
  192.         return upper$(left$(a.k$,29))
  193.     elseif a.l$<>""
  194.         return upper$(left$(a.l$,29))
  195.     elseif a.m$<>""
  196.         return upper$(left$(a.m$,29))
  197.     elseif a.n$<>""
  198.         return upper$(left$(a.n$,29))
  199.     elseif a.o$<>""
  200.         return upper$(left$(a.o$,29))
  201.     elseif a.p$<>""
  202.         return upper$(left$(a.p$,29))
  203.     endif
  204. endp
  205.  
  206. proc inSort:(s$,index%)
  207.     rem  Given a string, its position in the master database and
  208.     rem  a pre-defined string array a$(900,32), will insert the
  209.     rem  string in the correct position and prepend the index:
  210.     rem  nnntheString
  211.     local nld%,p%,x%,t$(29),n$(3)
  212.     nld%=index%-1
  213.     if nld%=0
  214.         a$(1)="001"+s$
  215.         return
  216.     endif
  217.     rem Build index string
  218.     n$=gen$(index%,3)
  219.     while len(n$)<3
  220.         n$="0"+n$
  221.     endwh
  222.     p%=1    rem p% is general index
  223.     rem Locate spot for insertion or appending
  224.     if len(a$(p%))>3
  225.         t$=mid$(a$(p%),4,29)
  226.     else
  227.         t$=""
  228.     endif
  229.     while s$>t$ and p%<=nld%
  230.         p%=p%+1
  231.         if len(a$(p%))>3
  232.             t$=mid$(a$(p%),4,29)
  233.         else
  234.             t$=""
  235.         endif
  236.     endwh
  237.     if p%>nld%    rem Append string to list
  238.         a$(nld%+1)=n$+s$
  239.     else        rem Shift everything up and insert string
  240.       nld%=index%
  241.         x%=nld%-1
  242.         do
  243.             a$(x%+1)=a$(x%)
  244.             x%=x%-1
  245.         until x%<p%
  246.         a$(p%)=n$+s$
  247.     endif
  248. endp
  249.  
  250. proc mod%:(a%,b%)            rem a% mod b%
  251.     if b%
  252.         return a%-(a%/b%)*b%
  253.     endif
  254. endp
  255.  
  256. proc progress:(t$,cur%,max%)
  257.     rem cur%    Current index
  258.     rem                    -also used for control
  259.     rem max%    Maximum index (total)
  260.     rem                    -also to pass window id
  261.     rem t$        Window title
  262.     local p,w,id,c,m
  263.     c=flt(cur%) :m=flt(max%)
  264.     if c>=0                        rem progress
  265.         w=146.0
  266.         if c<=m
  267.             gAT 22,17 :p=((c*100.0)/m)
  268.             gPatt -1,(p*(w/100.0))-1,8-2,3
  269.         endif
  270.         if t$<>""
  271.             gAT 3,10 :gPrintB t$,183,3
  272.         endif
  273.     elseif c=-1                rem create
  274.         id=gCreate(25,26,190,29,0)
  275.         gBorder $203
  276.         gAT 0,13 :gLineTo 220,gY
  277.         gAT 3,10 :gPrintB t$,183,3
  278.         gAT 20,23 :gPrint chr$(18);
  279.         gAT 164,gY :gPrint chr$(19);
  280.         gAT 22,16 :gLineTo 164,gY
  281.         gAT 22,23 :gLineTo 164,gY
  282.         gVisible on :return id
  283.     elseif c=-2                rem dispose
  284.         gClose max%
  285.     endif
  286. endp
  287.  
  288. proc signal:
  289.     local e%
  290.     e%=0
  291.     do
  292.         beep 3,100 :beep 3,200
  293.         e%=e%+1
  294.     until e%>2
  295. endp
  296.  
  297. proc swver$:
  298.     return "1.01 - Jim Hoyt"
  299. endp
  300.  
  301.  
  302.