home *** CD-ROM | disk | FTP | other *** search
/ Boot Disc 8 / boot-disc-1997-04.iso / PDA_Soft / Psion / games / Pipe / Pipe3a.opl next >
Text File  |  1994-07-05  |  11KB  |  467 lines
  1. REM Pipe3a ╕1994 Rudolf König
  2. REM rfkoenig@immd4.informatik.uni-erlangen.de
  3. REM Pipe3a has to be distributed under
  4. REM the GNU Copyleft (Version 2)
  5.  
  6. REM Following files are used:
  7. REM   \pic\pipeico.pic   icon for pipe3a
  8. REM   \pic\pipedata.pic  the pipe pieces
  9. REM   \opd\pipe3a.dat    scorefile, created if necessary
  10.  
  11. APP Pipe3a
  12.     type $1100
  13.     icon "\pic\pipeicon.pic"
  14. ENDA
  15.  
  16. PROC xpipe:
  17.     global bmapid%, width%, height%, scorew%
  18.     global field%, empty%, crs%, source%,level%, offset%
  19.     global posx%, posy%, sourcex%, sourcey%
  20.     global sccur%, scbon%, sctot%, scmin%
  21.     global flen%, mgidx%, occ%(7), totime%, tpcl$(8)
  22.     global flowdir%, fillgr%, drs$(50)
  23.     global hscfile$(64), hscname$(5,32), hsc%(5)
  24.     local i%, j%, ins%
  25.  
  26.     width% = 12 : height% = 10 : offset% = 40
  27.     flen% = width% * height% : scorew% = 140
  28.     field% = alloc(flen%+8)
  29.     if(field% = 0)
  30.         print "Not enough memory"
  31.         get : stop
  32.     endif
  33.  
  34.     gsetwin 0,0, 1,1 : screen 1,1,1,1
  35.     bmapid% = getbms%:
  36.     hscfile$ = "\opd\pipe3a.dat"
  37.     i% = gcreate(0,0, 16*width%+2*offset%+scorew%,16*height%, 1, 1)
  38.     statuswin on, 2
  39.  
  40.     rem *** possible flow direction per piece ***
  41.     drs$ = "20031430010140300213103010204402044103010204410301"
  42.     rem *** timeout per level: 200,180,160... ***
  43.     tpcl$ = "╚┤áîxdP<"
  44.     posx% = width%/2 : posy% = height%/2
  45.     empty% = 78 :crs% = 79 :source% = 54
  46.     fillgr% = 1
  47.     
  48.     rem *** load highscore ***
  49.     if exist (hscfile$)
  50.         open hscfile$, A, name$, score%
  51.         i% = 1 : j% = count
  52.         while j%
  53.             hscname$(i%) = A.name$ : hsc%(i%) = A.score%
  54.             i% = i% + 1 : j% = j% -1 : next
  55.         endwh
  56.         close
  57.     endif
  58.  
  59.     cache 2000,2000
  60.     level% = 0
  61.  
  62.     rem *** total of sixteen level ***
  63.     while (level% < 16)
  64.         sctot% = sctot% + sccur% + scbon%
  65.         initlev:
  66.         if (playlev:) : break : endif
  67.         level% = level% + 1
  68.     endwh
  69.  
  70.     rem *** Change highscore ***
  71.     if sctot% > hsc%(5)
  72.         dinit
  73.         dtext "", "Congratulations! You are in the top five!", 2
  74.         drs$ = ""
  75.         dedit drs$, "Your name", 16
  76.         if(dialog)
  77.             if exist(hscfile$) : delete hscfile$ : endif
  78.             create hscfile$, A, name$, score%
  79.             i% = 1 : j% = 0 : ins% = 1
  80.             while(j% < 5)
  81.                 if ins% AND sctot% > hsc%(i%)
  82.                     A.name$ = drs$ : A.score% = sctot%
  83.                     ins% = 0
  84.                 else
  85.                     A.name$ = hscname$(i%) : A.score% = hsc%(i%)
  86.                     i% = i% + 1
  87.                 endif
  88.                 append : j% = j% + 1
  89.             endwh
  90.             close
  91.         endif
  92.     endif
  93.     
  94.     showsc:
  95. ENDP
  96.  
  97. proc getbms%:
  98.     local file$(50), path$(128)
  99.  
  100.     file$="\pic\pipedata.pic"
  101.     path$="m:"+file$
  102.     if exist(path$)
  103.         return gloadbit(path$,0)
  104.     endif
  105.     path$="a:"+file$
  106.     if exist(path$)
  107.         return gloadbit(path$,0)
  108.     endif
  109.     path$="b:"+file$
  110.     if exist(path$)
  111.         return gloadbit(path$,0)
  112.     endif
  113.     return -1
  114. endp
  115.  
  116. PROC showsc:
  117.     local i%, j%, k%, ins%
  118.  
  119.     dinit
  120.     dtext "", "Pipe3a Highscore", 2
  121.     dtext "", " "
  122.     i% = 1 : j% = 1 : ins% = 1
  123.     while(j% < 6)
  124.         if ins% AND sctot% > hsc%(i%)
  125.             dtext gen$(j%,5)+"   *** Current game ***",gen$(sctot%,-10)
  126.             ins% = 0 : k% = k% + 1
  127.         else
  128.             if hscname$(i%) <> ""
  129.                 dtext gen$(j%,5)+"   "+hscname$(i%),gen$(hsc%(i%),-10)
  130.                 k% = k% + 1
  131.             endif : i% = i% + 1
  132.         endif : j% = j% + 1
  133.     endwh
  134.     if k% = 0 : dtext "", "*** No highscore yet ***" : endif
  135.     dialog
  136. ENDP
  137.  
  138. PROC initlev:
  139.     local i%, j%, k%, w%
  140.  
  141.     i% = 0
  142.     while (i% < flen%)
  143.         pokeb field%+i%, empty%
  144.         i% = i% + 1
  145.     endwh
  146.  
  147.     rem *** place the artifacts ***
  148.     randomize int(second)
  149.     i% = level% and 7
  150.     while(i% > 0)
  151.         j% = field% + int(rnd * flen%)
  152.         if(peekb(j%) = empty%)
  153.             i% = i% - 1
  154.             pokeb j%, 80 + rnd * 8
  155.         endif
  156.     endwh
  157.  
  158.     rem *** place the source ***
  159.     while(1)
  160.         sourcex% = 1 + int(rnd * (width%-2))
  161.         sourcey% = 1 + int(rnd * (height%-2))
  162.         j% = field% + sourcey%*width%+sourcex%
  163.         if(peekb(j%) = empty% and peekb(j%+1) = empty%)
  164.             pokeb j%, source% : break
  165.         endif
  166.     endwh
  167.     flowdir% = 4
  168.     
  169.     rem *** and now draw the field ***
  170.     ggrey 2 : gcls : ggrey 0
  171.     drawfld:
  172.     
  173.     gat 4,0 : gxborder 1, $201, 32, height%*16
  174.     gat offset%+16*width%+4,0 : gxborder 1, $201, 32, height%*16
  175.     drawp:(crs%,posx%,posy%,0)
  176.  
  177.     rem *** buid the magazin ***
  178.     i% = 0
  179.     while(i% < 8)
  180.         j% = getp:
  181.         pokeb field%+flen%+i%, j%
  182.         drawp:(j%, -1, i%, 3)
  183.         i% = i% + 1
  184.     endwh
  185.     mgidx% = 7
  186.  
  187.     rem *** draw the status fields ***
  188.     i% = 0
  189.     scmin% = 2*level%+1 : sccur% = 0 : scbon% = 0
  190.  
  191.     while( i% < 6 )
  192.         gat 2*offset% + width% * 16 + 4, i% * 27
  193.         gxborder 1,$201, scorew%-8,25
  194.         pscore:(i%+1, 0) : i% = i% + 1
  195.     endwh
  196.     
  197. ENDP
  198.  
  199. PROC drawfld:
  200.     local i%, j%, k%, w%
  201.     
  202.     k% = 0 : i% = 0 : j% = 0
  203.     while(k% < flen%)
  204.         w% = peekb(field% + k%)
  205.         drawp:(w%, i%, j%, 3)
  206.         i% = i% + 1 : k% = k% + 1
  207.         if(i% = width%)
  208.             i% = 0 : j% = j% + 1
  209.         endif
  210.     endwh
  211. ENDP
  212.  
  213. rem *** change status line row% by amount d% ***
  214. PROC pscore:(row%,d%)
  215.     local txt$(30)
  216.  
  217.     gat 2*offset% + width% * 16 + 16, (row%-1) * 27 + 18
  218.     vector row%
  219.         cur, bon, tot, ren, hig, lev
  220.     endv
  221.     cur:: sccur% = sccur%+d% : txt$="Current: "+gen$(sccur%,7) : goto drsc
  222.     bon:: scbon% = scbon%+d% : txt$="Bonus: "+gen$(scbon%,7) : goto drsc
  223.     tot:: sctot% = sctot%+d% : txt$="Score: "+gen$(sctot%,7) : goto drsc
  224.     ren:: scmin% = scmin%+d% : if(scmin% < 0) : return : endif : txt$="Minimum: "+gen$(scmin%,7) : goto drsc
  225.     hig:: txt$="Hiscore: "+gen$(hsc%(1),7) : goto drsc
  226.     lev:: txt$="Level: "+gen$(level%+1,7)
  227.   drsc::
  228.     gprintb txt$, scorew%-32, 3
  229. ENDP
  230.  
  231. rem *** generate a new piece ***
  232. PROC getp:
  233.     local i%, idx%
  234.     rem *** rnd is not very equally distributed ***
  235.     do
  236.         idx% = 1+int(rnd*7) : i% = 1
  237.         while(occ%(idx%) - occ%(i%) < 2)
  238.             i% = i% + 1
  239.             if i% > 7 : break : endif
  240.         endwh
  241.     until i% > 7
  242.  
  243.     occ%(idx%) = occ%(idx%)+1
  244.     idx% = (idx%-1)*8
  245.  
  246.     rem *** the unidirectonal parts ***
  247.     if level% > 7 AND idx% < 48 AND rnd < 0.3
  248.         if rnd > .5 : idx% = idx% + 6 : else : idx% = idx% + 7 : endif
  249.     endif
  250.     
  251.     return idx%
  252. ENDP
  253.  
  254. rem *** draw piece idx% at x%,y%, for x% < 0 in th magazin ***
  255. PROC drawp:(idx%,x%,y%,mode%)
  256.     if(x% >= 0)
  257.         gat 16*x%+offset%, 16*y%
  258.     else
  259.         gat 12, 18*y%+10
  260.     endif
  261.     gcopy bmapid%, 16*(idx% AND 7), 16*(idx%/8),16,16,mode%
  262. ENDP
  263.  
  264. rem *** take a piece from  the magazin and place it at the current position ***
  265. PROC setp:
  266.     local b%, c%, w%, j%
  267.     
  268.     j% = field% + posy% * width% + posx%
  269.     w% = peekb(field%+flen%+mgidx%)
  270.     b% = peekb(j%)
  271.     if(b% <> empty%)
  272.         c% = b% and 7
  273.         if (b% > 48 or (c% > 0 and c% < 6))
  274.             beep 5,300: return
  275.         else
  276.             pscore:(2,-20)
  277.         endif
  278.     endif
  279.     drawp:(w%, posx%,posy%, 3)
  280.     pokeb j%, w%
  281.     gscroll 0, 18, 12, 10, 16, 126
  282.     w% = getp:
  283.     pokeb field%+flen%+mgidx%, w%
  284.     drawp:(w%, -1, 0, 3)
  285.     mgidx% = (mgidx%-1) and 7
  286.     drawp:(crs%, posx%, posy%, 0)
  287. ENDP
  288.  
  289. rem *** remove the unused pieces ***
  290. PROC remrest:
  291.     local w%, v%, i%, j%, k%(6)
  292.  
  293.     rem *** remove not filled stones ***
  294.     while(j% < height%)
  295.         i% = 0
  296.         while(i% < width%)
  297.             w% = peekb(field% + j%*width% + i%)
  298.             v% = w% AND 7
  299.             if (v% = 0 and w% < 56) or ((v% = 6 or v% = 7) and w% < 48)
  300.                 pscore:(2, -10)
  301.             endif
  302.             i% = i% + 1
  303.         endwh
  304.         j% = j% + 1
  305.     endwh
  306.     while testevent : getevent k%() : endwh
  307.     get
  308. ENDP
  309.  
  310. rem *** handle a keypress event ***
  311. PROC dokey:(ky%):
  312.     local i%, j%, r%, c%, w%, k%
  313.  
  314.     k% = ky%
  315.     if(k% > 255 AND k% < 260)
  316.         w% = peekb(field% + posy%*width%+posx%)
  317.         r% = w% / 8 : c% = w% AND 7
  318.         if fillgr% and r%<10 and ((c%>0 and c%<6) or (r%>7 and c%=0))
  319.             if r% > 6 : r% = 6 : endif
  320.             drawp:(r%*8, posx%, posy%, 3)
  321.             ggrey 1 : drawp:(w%, posx%, posy%, 3) : ggrey 0
  322.         else
  323.             drawp:(w%, posx%, posy%, 3)
  324.         endif
  325.         
  326.         vector k% - 255
  327.             doup,dodown, doright, doleft
  328.         endv
  329.         doup::    posy% = posy% - 1 : if(posy% < 0) : posy% = height%-1 : endif : goto dodraw
  330.         dodown::  posy% = posy% + 1 : if(posy% > height%-1) : posy% = 0 : endif : goto dodraw
  331.         doright:: posx% = posx% + 1 : if(posx% > width%-1)  : posx% = 0 : endif : goto dodraw
  332.         doleft::  posx% = posx% - 1 : if(posx% < 0) : posx% = width% -1 : endif
  333.         dodraw::  drawp:(crs%, posx%, posy%, 0)
  334.     endif
  335.     if(k% = 32 or k% = 13) : setp: : endif
  336.     if(k% = 27)
  337.         while(flowing:) : pause 2 : endwh
  338.         remrest: : return 0
  339.     endif
  340.     if k% = 290 : rem Menu
  341.         minit
  342.         mcard "Pipe3a", "Show highscore", %s, "Version", %v, "Exit", %x
  343.         k% = menu + $200
  344.     endif
  345.     if k% = $267 : fillgr% = 1 - fillgr% : endif
  346.     if k% = $278 : stop : endif
  347.     if k% = $273 : showsc: : endif
  348.     if k% = $276
  349.         dinit
  350.         dtext "", "Pipe3a - Version  1.00", 2
  351.         dtext "", "Copyright ╕ 1994 by Rudolf König", 2
  352.         dtext "", "Pipe3a has to be distributed under the", 2
  353.         dtext "", "GNU Copyleft (Version 2)", 2
  354.         dialog
  355.     endif
  356.     return 1
  357.  
  358. ENDP
  359.  
  360. rem *** handle all events for a level ***
  361. PROC playlev:
  362.     local k%(6), t%, tpc%
  363.  
  364.     totime% = 0 : tpc% = asc(mid$(tpcl$,(level% and 7) + 1,1)) * 7
  365.     while 1
  366.         pause 1
  367.  
  368.         rem *** do timout ***
  369.         t% = t% + 1
  370.         if t% > tpc%
  371.             t% = 1
  372.             if(totime% < 150)
  373.                 timeout:
  374.             else
  375.                 tpc% = 200
  376.                 if flowing: = 0
  377.                     remrest:
  378.                     if scmin% > 0 : return 1 : else : return 0 : endif
  379.                 endif
  380.             endif
  381.         endif
  382.         
  383.         while testevent
  384.             getevent k%()
  385.             if k%(1) and $400
  386.                 if k%(1) = $402 : rem background
  387.                     while 1
  388.                         getevent k%()
  389.                         if k%(1) = $401 : break : endif
  390.                         if k%(1) = $404 : stop : endif
  391.                     endwh
  392.                 endif
  393.                 break
  394.             endif
  395.           
  396.             if dokey:(k%(1)) = 0
  397.                 if scmin% > 0 : return 1 : else : return 0 : endif
  398.             endif
  399.         endwh
  400.     endwh
  401. ENDP
  402.  
  403. rem *** fill the pipe a little more ***
  404. PROC flowing:
  405.     local row%, col%, r%, j%, k%, x%, y%, p%
  406.     local d%
  407.     
  408.     r% = 1
  409.     x% = sourcex% : y% = sourcey%
  410.     j% = field% + y% * width% + x%
  411.     p% = peekb(j%)
  412.     if(p% = 62) : p% = 63 : sourcex% = sourcex% + 1 : goto drawit : endif
  413.     if(p% = 55) : p% = 62 : goto drawit : endif
  414.     if(p% = 54) : p% = 55 : goto drawit : endif
  415.  
  416.     if(p% = empty% or p% >= 80) : return 0 : endif
  417.  
  418.     row% = p% / 8 : col% = p% and 7
  419.     vector col%
  420.         c1,c2,c3,c4
  421.     endv
  422.  
  423.     if(row% = 6 and (flowdir% = 1 or flowdir% = 3)) : row% = 7 : endif
  424.     d% = asc(mid$(drs$,row%*5+flowdir%,1))-48
  425.     if d% = 0 : return 0 : endif
  426.     k% = asc(mid$(drs$,row%*5+5,1))-48
  427.     if col%
  428.         if (k% = flowdir% AND col% = 7) OR (k% <> flowdir% AND col% = 6)
  429.             return 0
  430.         endif
  431.         pscore:(2, 10)
  432.     endif
  433.     if k% = flowdir% : p% = row%*8+1 : else : p% = row%*8+3 : endif
  434.     flowdir% = d% 
  435.     goto drawit
  436.     c1::p% = p% + 1 : goto drawit
  437.     c2::p% = p% + 3 : goto c5
  438.     c3::p% = p% + 1 : goto drawit
  439.     c4::p% = p% + 1
  440.     c5::
  441.         pscore:(4, -1) : pscore:(1, 10)
  442.         if(row% > 7) : pscore:(2, 40) : endif
  443.         if(row% = 6) : p% = 72 : endif
  444.         if(row% = 7) : p% = 64 : endif
  445.         if(flowdir% = 3) : sourcey% = sourcey% - 1 : if(sourcey% < 0) : r% = 0 : endif : endif
  446.         if(flowdir% = 4) : sourcex% = sourcex% + 1 : if(sourcey% > width%) : r% = 0 : endif : endif
  447.         if(flowdir% = 1) : sourcey% = sourcey% + 1 : if(sourcey% > height%) : r% = 0 : endif : endif
  448.         if(flowdir% = 2) : sourcex% = sourcex% - 1 : if(sourcex% < 0) : r% = 0 : endif : endif
  449.  
  450.     drawit::
  451.     if(fillgr%)
  452.         ggrey 1 : drawp:(p%,x%,y%,3) : ggrey 0
  453.     else
  454.         drawp:(p%,x%,y%,3)
  455.     endif
  456.     pokeb j%, p%
  457.  
  458.     return r%
  459. ENDP
  460.  
  461. rem *** draw the timeout bar ***
  462. PROC timeout:
  463.     gat offset%+width%*16+8, 5 + totime%
  464.     glineby 24,0
  465.     totime% = totime% + 1
  466. ENDP
  467.