home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / siena / oplexam / OPLEXAM.TXT < prev    next >
Encoding:
Text File  |  1995-04-11  |  36.1 KB  |  1,582 lines
  1. 1: Creating and running programs
  2.  
  3. 2: Variables and constants
  4.  
  5. 3: Loops and branches
  6.  
  7. 4: Calling procedures
  8.  
  9. 5: Data file handling
  10.  
  11. PROC openfile:
  12.   IF NOT EXIST("example")
  13.     CREATE "example",A,int%,lng&,fp,str$
  14.   ELSE
  15.     OPEN "example",A,int%,lng&,fp,str$
  16.   ENDIF
  17.   PRINT "Current values:"
  18.   show:
  19.   PRINT "Assigning values"
  20.   A.int%=1
  21.   A.lng&=&2**20   REM the 1st & avoids integer overflow
  22.   A.fp=SIN(PI/6)
  23.   PRINT "Give a value for the string:"
  24.   INPUT A.str$
  25.   PRINT "New values:"
  26.   show:
  27. ENDP
  28.  
  29. PROC show:
  30.   PRINT "integer=";A.int%
  31.   PRINT "long=";A.lng&
  32.   PRINT "float=";A.fp
  33.   PRINT "string=";A.str$
  34.   GET
  35. ENDP
  36.  
  37. PROC count:
  38.   LOCAL reply%
  39.   OPEN "example",A,f%,f&,f,f$
  40.   DO
  41.     CLS
  42.     AT 20,1 :PRINT "Record count=";COUNT
  43.     AT 9,5 :PRINT "(A)dd a record"
  44.     AT 9,7 :PRINT "(Q)uit"
  45.     reply%=GET
  46.     IF reply%=%q OR reply%=%Q
  47.       BREAK
  48.     ELSEIF reply%=%A OR reply%=%a
  49.       add:
  50.     ELSE
  51.       BEEP 16,250
  52.     ENDIF
  53.   UNTIL 0
  54. ENDP
  55.  
  56. PROC add:
  57.   CLS
  58.   PRINT "Enter integer field:";
  59.   INPUT A.f%
  60.   PRINT "Enter long integer field:";
  61.   INPUT A.f&
  62.   PRINT "Enter numeric field:";
  63.   INPUT A.f
  64.   PRINT "Enter string field:";
  65.   INPUT A.f$
  66.   APPEND
  67. ENDP
  68.  
  69. FIRST
  70. WHILE FIND("*BROWN*")
  71.   PRINT a.name$, a.phone$
  72.   NEXT
  73.   GET
  74. ENDWH
  75.  
  76. PROC copyrec:
  77.   OPEN "example",A,f%,f&,f,f$
  78.   TRAP DELETE "temp"
  79.   REM If file doesn't exist, ignore error
  80.   CREATE "temp",B,f%,f&,f,f$
  81.   PRINT "Copying EXAMPLE to TEMP"
  82.   USE A REM the EXAMPLE file
  83.   DO
  84.     IF a.f%>30 and a.f<3.1415
  85.       b.f%=a.f%
  86.       b.f&=a.f&
  87.       b.f=a.f
  88.       b.f$="Selective copy"
  89.       USE B REM the TEMP file
  90.       APPEND
  91.       USE A
  92.     ENDIF
  93.     NEXT
  94.   UNTIL EOF REM until End Of File
  95.   CLOSE REM closes A; B becomes current
  96.   CLOSE REM closes B
  97. ENDP
  98.  
  99. p%=PEEKW($1c)+$1e
  100. POKEW p%,PEEKW(p%) or 1
  101.  
  102. p%=PEEKW($1c)+$1e
  103. POKEW p%,PEEKW(p%) and $fffe
  104.  
  105. 6: Graphics
  106.  
  107. PROC exgrey:
  108.   DEFAULTWIN 1                       REM enable grey
  109.   gAT 0,40  :gGREY 1 :gLINEBY 480,0  REM grey only
  110.   gAT 0,41  :gLINEBY 480,0
  111.   gAT 0,80  :gGREY 0 :gLINEBY 480,0  REM black only
  112.   gAT 0,81  :gLINEBY 480,0
  113.   gAT 0,120 :gGREY 2 :gLINEBY 480,0  REM both planes
  114.   gAT 0,121  :gLINEBY 480,0
  115.   GET
  116.   gGREY 0                            REM black only
  117.   gCLS                               REM clear it
  118.   GET
  119. ENDP
  120.  
  121. PROC face:
  122.   gFILL 120,120,0 REM set the entire face
  123.   gMOVE 10,20 :gFILL 30,20,1 REM left eye
  124.   gMOVE 70,0 :gFILL 30,20,1 REM right eye
  125.   gMOVE -30,30 :gFILL 20,30,1 REM nose
  126.   gMOVE -20,40 :gFILL 60,20,1 REM mouth
  127.   GET
  128. ENDP
  129.  
  130. PROC wink:
  131.   gMOVE 10,20 REM move to left eye
  132.   gFILL 30,14,2 REM invert most of the eye
  133.   PAUSE 10
  134.   gFILL 30,14,2 REM invert it back again
  135.   GET
  136. ENDP
  137.  
  138. PROC brow:
  139.   gGMODE 1 REM gLINEBY will now clear pixels
  140.   gMOVE 10,8 :gLINEBY 100,0
  141.   gMOVE 0,4 :gLINEBY -100,0
  142.   gGMODE 0
  143.   GET
  144. ENDP
  145.  
  146. PROC fonts:
  147.   showfont:(4,15,"Mono 8x8")
  148.   showfont:(5,25,"Roman 8")
  149.   showfont:(6,38,"Roman 11")
  150.   showfont:(7,53,"Roman 13")
  151.   showfont:(8,71,"Roman 16")
  152.   showfont:(9,81,"Swiss 8")
  153.   showfont:(10,94,"Swiss 11")
  154.   showfont:(11,109,"Swiss 13")
  155.   showfont:(12,127,"Swiss 16")
  156.   showfont:(13,135,"Mono 6x6")
  157.   GET
  158. ENDP
  159.  
  160. PROC showfont:(font%,y%,str$)
  161.     gFONT font%
  162.     gAT 20,y% :gPRINT font%
  163.     gAT 50,y% :gPRINT str$
  164.     gAT 150,y% :gPRINT "!!!"
  165. ENDP
  166.  
  167. PROC style:
  168.   gAT 20,50 :gFONT 11
  169.   gSTYLE 12 :gPRINT "Attention!"
  170.   GET
  171. ENDP
  172.  
  173. PROC tmode:
  174.   DEFAULTWIN 1                REM enable grey
  175.   gFONT 11    :gSTYLE 0
  176.   gAT 160,0   :gFILL 160,80,0 REM Black box
  177.   gAT 220,0   :gFILL 40,80,1  REM White box
  178.   gAT 180,20  :gTMODE 0 :gPRINT "ABCDEFGHIJK"
  179.   gAT 180,35  :gTMODE 1 :gPRINT "ABCDEFGHIJK"
  180.   gAT 180,50  :gTMODE 2 :gPRINT "ABCDEFGHIJK"
  181.   gAT 180,65  :gTMODE 3 :gPRINT "ABCDEFGHIJK"
  182.   gGREY 1
  183.   gAT 160,80  :gFILL 160,80,0 REM Grey box
  184.   gAT 220,80  :gFILL 40,80,1  REM White box
  185.   gAT 180,100 :gTMODE 0 :gPRINT "ABCDEFGHIJK"
  186.   gAT 180,115 :gTMODE 1 :gPRINT "ABCDEFGHIJK"
  187.   gAT 180,130 :gTMODE 2 :gPRINT "ABCDEFGHIJK"
  188.   gAT 180,145 :gTMODE 3 :gPRINT "ABCDEFGHIJK"
  189.   GET
  190. ENDP
  191.  
  192. PROC windows:
  193.   LOCAL id%
  194.   id%=gCREATE(60,40,240,30,1,1)
  195.   gBORDER 0 :gAT 20,20 :gLINEBY 0,0
  196.   gPRINT " 20,20 (new)"
  197.   GET
  198.   gUSE 1 :gAT 20,20 :gLINEBY 0,0
  199.   gPRINT " 20,20 (default)"
  200.   GET
  201.   gUSE id%
  202.   gGREY 1        REM draw grey
  203.   gPRINT " Back"
  204.   gGREY 0
  205.   gPRINT " (with grey)"
  206.   GET
  207. ENDP
  208.  
  209. PROC gsetw1:
  210.   LOCAL a$(100),w%,h%,g$(1),factor%,info%(10)
  211.   LOCAL margx%,margy%,chrw%,chrh%,defw%,defh%
  212.   SCREENINFO info%()       REM get text window information
  213.   margx%=info%(1) :margy%=info%(2)
  214.   chrw%=info%(7) :chrh%=info%(8)
  215.   defw%=23*chrw%+2*margx%  REM new default window width
  216.   defh%=chrh%+2*margy%     REM ... and height
  217.   w%=gWIDTH :h%=gHEIGHT
  218.   gSETWIN w%/4+margx%,h%/4+margy%,defw%,defh%
  219.   SCREEN 23,1,1,1   REM text window
  220.   PRINT "Text win:"; :GET
  221.   gCREATE(w%*.1,h%*.1,w%*.8,h%*.8,1)   REM new window
  222.   gPATT -1,gWIDTH,gHEIGHT,0 REM shade it
  223.   gAT 2,h%*.7 :gTMODE 4
  224.   gPRINT "Graphics window 2"
  225.   gORDER 1,0 REM back to default+text window
  226.   EDIT a$               REM you can see this edit
  227.   gORDER 1,9 REM to background
  228.   CLS
  229.   a$=""
  230.   PRINT "Hidden:";
  231.   GIPRINT "Edit in hidden edit box"
  232.   EDIT a$               REM YOU CAN'T SEE THIS EDIT
  233.   GIPRINT ""
  234.   gORDER 1,0 :GET REM now here it is
  235.   gUSE 1 REM graphics go to default window
  236.   DO  REM move default/text window around
  237.     CLS
  238.     PRINT "U,D,L,R,Quit";
  239.     g$=UPPER$(GET$)
  240.     IF kmod=2 REM Shift key moves quickly
  241.       factor%=10
  242.     ELSE
  243.       factor%=1
  244.     ENDIF
  245.     IF g$="U"
  246.       gSETWIN gORIGINX,gORIGINY-factor%
  247.     ELSEIF g$="D"
  248.       gSETWIN gORIGINX,gORIGINY+factor%
  249.     ELSEIF g$="L"
  250.       gSETWIN gORIGINX-factor%,gORIGINY
  251.     ELSEIF g$="R"
  252.       gSETWIN gORIGINX+factor%,gORIGINY
  253.     ENDIF
  254.   UNTIL g$="Q" OR g$=CHR$(27)
  255. ENDP
  256.  
  257. 7: Friendlier interaction
  258.  
  259. PROC kget%:
  260.   LOCAL k%,h$(9),a$(5)
  261.   h$="nosciefgd" REM our hot-keys
  262.   WHILE 1
  263.     k%=GET
  264.     IF k%=$122   REM Menu key?
  265.       mINIT
  266.       mCARD "File","New",%n,"Open",%o,"Save",%s
  267.       mCARD "Edit","Copy",%c,"Insert",-%i,"Eval",%e
  268.       mCARD "Search","First",%f,"Next",%g,"Previous",%d
  269.       k%=MENU
  270.       IF k% AND (LOC(h$,CHR$(k%))<>0)     REM MENU CHECK
  271.          a$="proc"+CHR$(k%)
  272.         @(a$): REM procn:, proco:, ...
  273.       ENDIF                        REM END OF MENU CHECK
  274.     ELSEIF k% AND $200  REM hot-key pressed directly?
  275.       k%=k%-$200        REM remove Psion key code
  276.       IF LOC(h$,CHR$(k%))       REM DIRECT HOT-KEY CHECK
  277.          a$="proc"+CHR$(k%)
  278.         @(a$): REM procn:, proco:, ...
  279.       ENDIF              REM END OF DIRECT HOT-KEY CHECK
  280.     ELSE REM some other key
  281.       RETURN k%
  282.     ENDIF
  283.   ENDWH
  284. ENDP
  285.  
  286. PROC procn:
  287. ...
  288. ENDP
  289.  
  290. PROC proco:
  291. ...
  292. ENDP
  293.  
  294. IF k%<=%Z     REM if upper case hot-key
  295.   IF LOC(hu$,CHR$(k%))
  296.     a$="procu"+CHR$(k%)
  297.     @(a$) :REM procua:, procuc:, ...
  298.   ENDIF
  299. ELSE          REM else lower case hot-key
  300.   IF LOC(hl$,CHR$(k%))
  301.     a$="procl"+CHR$(k%)
  302.     @(a$) :REM procla:, procld:, ...
  303.   ENDIF
  304. ENDIF
  305.  
  306. PROC dcheck:
  307.   LOCAL c%
  308.   c%=2         REM default to "Internal"
  309.   dINIT "Disk Check"
  310.   dCHOICE c%,"Disk:","A,Internal,B"
  311.   IF DIALOG    REM returns 0 if cancelled
  312.     ... REM disk-check code
  313.   ENDIF
  314. ENDP
  315.  
  316. PROC delivery:
  317.   LOCAL d&,t&,num&,wt
  318.   d&=DAYS(DAY,MONTH,YEAR)
  319.   DO
  320.     t&=secs&:
  321.   UNTIL t&=secs&:
  322.   num&=1 :wt=10
  323.   dINIT "Delivery"
  324.   dLONG num&,"Boxes",1,1000
  325.   dFLOAT wt,"Weight (kg)",0,10000
  326.   dDATE d&,"Date",d&,DAYS(31,12,1999)
  327.   dTIME t&,"Time",0,0,DATETOSECS(1970,1,1,23,59,59)
  328.   IF DIALOG    REM returns 0 if cancelled
  329.     ...  REM rest of code
  330.   ENDIF
  331. ENDP
  332.  
  333. PROC secs&:
  334.    RETURN HOUR*INT(3600)+MINUTE*60
  335. ENDP
  336.  
  337. PROC daytodat:(days&)
  338.   LOCAL dyscent&(2),dateent%(4)
  339.   LOCAL flags%,ax%,bx%,cx%,dx%,si%,di%
  340.   dyscent&(1)=days&
  341.   si%=ADDR(dyscent&()) :di%=ADDR(dateent%())
  342.   ax%=$0600 REM TimDaySecondsToDate fn.
  343.   flags%=OS($89,ADDR(ax%)) REM TimManager int.
  344.   IF flags% AND 1
  345.     RAISE (ax% OR $ff00)
  346.   ELSE
  347.     year%=PEEKB(di%)+1900 :month%=PEEKB(UADD(di%,1))+1
  348.     day%=PEEKB(UADD(di%,2))+1 :yrdy%=PEEKW(UADD(di%,6))+1
  349.   ENDIF
  350. ENDP
  351.  
  352. PROC selact:
  353.   dINIT "Select action"
  354.   dTEXT "","Add",$402
  355.   dTEXT "","Copy",$402
  356.   dTEXT "","Review",$402
  357.   dTEXT "","Delete",$402
  358.   RETURN DIALOG
  359. ENDP
  360.  
  361. 8: OPL and Solid State Disks
  362.  
  363. PROC delx300:
  364.   LOCAL a$(3),c%
  365.   a$="MAB" :c%=1 REM default to "Internal"
  366.   dINIT "Delete X300 data file"
  367.   dCHOICE c%,"Disk:","Internal,A,B"
  368.   IF DIALOG REM returns 0 if cancelled
  369.     DELETE MID$(A$,c%,1)+":X300"
  370.   ENDIF
  371. ENDP
  372.  
  373. 9: Example programs
  374.  
  375. PROC timer:
  376.   LOCAL min&,sec&,secs&,i%
  377.   CACHE 2000,2000
  378.   sec&=1
  379.   dINIT "Countdown timer"
  380.   dLONG min&,"Minutes",0,59
  381.   dLONG sec&,"Seconds",0,59
  382.   dBUTTONS "Cancel",-27,"Start",13
  383.   IF DIALOG=13
  384.     STATUSWIN ON
  385.     FONT 11,16
  386.     secs&=sec&+60*min&
  387.     WHILE secs&
  388.       PAUSE -20
  389.       REM a key gets us out
  390.       IF KEY
  391.         RETURN
  392.       ENDIF
  393.       secs&=secs&-1
  394.       AT 20,6 :PRINT NUM$(secs&/60,-2);"m"
  395.       AT 24,6 :PRINT NUM$(mod&:(secs&,int(60)),-2);"s"
  396.     ENDWH
  397.     DO
  398.       BEEP 5,300
  399.       PAUSE 10
  400.       IF KEY :BREAK :ENDIF
  401.        i%=i%+1
  402.     UNTIL i%=10
  403.   ENDIF
  404. ENDP
  405.  
  406. PROC mod&:(a&,b&)
  407.   REM modulo function
  408.   REM computes (a&)mod(b&)
  409.   RETURN a&-(a&/b&)*b&
  410. ENDP
  411.  
  412. PROC dice:
  413.   LOCAL dice%
  414.   DO
  415.     CLS :PRINT "DICE ROLLING:"
  416.     AT 1,3 :PRINT "Press a key to stop"
  417.     DO
  418.       dice%=(RND*6+1)
  419.       AT 1,2 :PRINT dice%
  420.     UNTIL KEY
  421.     BEEP 5,300
  422.     dINIT "Roll again?"
  423.     dBUTTONS "No",%N,"Yes",%Y
  424.   UNTIL DIALOG<>%y
  425. ENDP
  426.  
  427. PROC Birthday:
  428.   LOCAL day&,month&,year&,DayInWk%
  429.   DO
  430.     dINIT
  431.     dTEXT "","Enter your date of birth",2
  432.     dTEXT "","Use numbers, eg 23 12 1963",$202
  433.     dLONG day&,"Day",1,31
  434.     dLONG month&,"Month",1,12
  435.     dLONG year&,"Year",1900,2155
  436.     IF DIALOG=0
  437.       BREAK
  438.     ENDIF
  439.     DayInWk%=DOW(day&,month&,year&)
  440.     CLS :PRINT DAYNAME$(DayInWk%),day&,month&,year&
  441.     dINIT "Again?"
  442.     dBUTTONS "No",%N,"Yes",%Y
  443.   UNTIL DIALOG<>%y
  444. ENDP 
  445.  
  446. PROC files:
  447.   GLOBAL nm$(255),ad1$(255),ad2$(255)
  448.   GLOBAL ad3$(255),ad4$(255),tel$(255),title$(30)
  449.   LOCAL g%
  450.   OPEN "DATA",A,nm$,ad1$,ad2$,ad3$,ad4$,tel$
  451.   DO
  452.     CLS
  453.     dINIT "Select action"
  454.     dTEXT "","Add new record",$402
  455.     dTEXT "","Find and edit a record",$402
  456.     g%=DIALOG
  457.     IF g%=2
  458.       add:
  459.     ELSEIF g%=3
  460.       edit:
  461.     ENDIF
  462.   UNTIL g%=0
  463.   CLOSE
  464. ENDP
  465.  
  466. PROC add:
  467.   nm$="" :ad1$="" :ad2$=""
  468.   ad3$="" :ad4$="" :tel$=""
  469.   title$="Enter a new record"
  470.   IF showd%:
  471.     APPEND
  472.   ENDIF
  473. ENDP
  474.  
  475. PROC edit:
  476.   LOCAL search$(30),p%
  477.   dINIT "Find and edit a record"
  478.   dEDIT search$,"Search string",15
  479.   IF DIALOG
  480.     FIRST
  481.     IF FIND("*"+search$+"*")=0
  482.       ALERT("No matching records")
  483.       RETURN
  484.     ENDIF
  485.     DO
  486.       nm$=A.nm$ :ad1$=A.ad1$ :ad2$=A.ad2$
  487.       ad3$=A.ad3$ :ad4$=A.ad4$ :tel$=A.tel$
  488.       title$="Edit matching record"
  489.       IF showd%:
  490.         UPDATE :BREAK
  491.       ELSE
  492.         NEXT
  493.       ENDIF
  494.       FIND("*"+search$+"*")
  495.       IF EOF
  496.         ALERT("No more matching records")
  497.         BREAK
  498.       ENDIF
  499.     UNTIL 0
  500.   ENDIF
  501. ENDP 
  502.  
  503. PROC showd%:
  504.   LOCAL ret%
  505.   dINIT title$
  506.   dEDIT nm$,"Name",25
  507.   dEDIT ad1$,"Street",25
  508.   dEDIT ad2$,"Town",25
  509.   dEDIT ad3$,"County",25
  510.   dEDIT ad4$,"Postcode",25
  511.   dEDIT tel$,"Phone",25
  512.   ret%=DIALOG
  513.   IF ret%
  514.     A.nm$=nm$ :A.ad1$=ad1$ :A.ad2$=ad2$
  515.     A.ad3$=ad3$ :A.ad4$=ad4$ :A.tel$=tel$
  516.   ENDIF
  517.   RETURN ret%
  518. ENDP
  519.  
  520. PROC reorder:
  521.   LOCAL last%,e$(255),e%,lpos%,n$(128),c%
  522.   n$="\dat\*.dbf"
  523.   dINIT "Re-order Data file"
  524.   dFILE n$,"Filename",0
  525.   IF DIALOG REM returns 0 if cancelled
  526.     OPEN n$,a,a$
  527.     LAST :last%=POS
  528.     IF COUNT>0
  529.       WHILE last%<>0
  530.         POSITION last% :e%=POS
  531.         e$=UPPER$(a.a$)
  532.         DO
  533.           IF UPPER$(a.a$)<e$
  534.             e$=UPPER$(a.a$) :e%=POS
  535.           ENDIF
  536.           lpos%=POS :BACK
  537.         UNTIL pos=1 and lpos%=1
  538.         POSITION e%
  539.         PRINT e$
  540.         UPDATE :last%=last%-1
  541.       ENDWH
  542.     ENDIF
  543.     CLOSE
  544.   ENDIF
  545. ENDP
  546.  
  547. PROC watch:
  548.   LOCAL k%,s%,se%,mi%
  549.   FONT 11,16
  550.   AT 20,1 :PRINT "Stopwatch"
  551.   AT 15,11 :PRINT "Press a key to start"
  552.   GET
  553.   DO
  554.   CLS :mi%=0:se%=0:s%=SECOND
  555.   AT 15,11 :PRINT "   S=Stop, L=Lap    "
  556.   loop::
  557.   k%=KEY AND $ffdf REM ensures upper case
  558.   IF k%=%S
  559.     GOTO pause::
  560.   ENDIF
  561.   IF k%=%L
  562.     AT 20,6 :PRINT "Lap: ";mi%;":";
  563.     IF se%<10 :PRINT "0"; :ENDIF
  564.     PRINT se%;" ";
  565.   ENDIF
  566.   IF SECOND<>s%
  567.     s%=SECOND :se%=se%+1
  568.     IF se%=60 :se%=0:mi%=mi%+1 :ENDIF
  569.     AT 17,8
  570.     PRINT "Mins",mi%,"Secs",
  571.     IF se%<10 :PRINT "0"; :ENDIF
  572.     PRINT se%;" ";
  573.   ENDIF
  574.   GOTO loop::
  575.   pause::
  576.   mINIT
  577.   mCARD "Watch","Restart",%r,"Zero",%z,"Exit",%x
  578.   k%=MENU
  579.   IF k%=%r
  580.     GOTO loop::
  581.   ENDIF
  582.   UNTIL k%<>%z
  583. ENDP
  584.  
  585. PROC label:
  586. LOCAL a%,b%,c%,d%,s$(128),s&,i$(17,255)
  587. s$="\dat\*.dbf"
  588. dINIT "Insert new field"
  589. dFILE s$,"Data file",0
  590. dLONG s&,"Break at line (1-16)",1,16
  591. IF DIALOG
  592. OPEN s$,A,a$,b$,c$,d$,e$,f$,g$,h$,i$,j$,k$,l$,m$,n$,o$,p$,q$
  593.   c%=COUNT :a%=1
  594.   WHILE a%<=c%
  595.     AT 1,1 :PRINT "Entry",a%,"of",c%,
  596.     IF A.q$="" REM Entry (hopefully) not too long
  597.       i$(1)=A.a$ :i$(2)=A.b$ :i$(3)=A.c$ :i$(4)=A.d$
  598.       i$(5)=A.e$ :i$(6)=A.f$ :i$(7)=A.g$ :i$(8)=A.h$
  599.       i$(9)=A.i$ :i$(10)=A.j$ :i$(11)=A.k$ :i$(12)=A.l$
  600.       i$(13)=A.m$ :i$(14)=A.n$ :i$(15)=A.o$ :i$(16)=A.p$
  601.       d%=0 :b%=0
  602.       WHILE d%<s&+b% REM find field to break at
  603.         d%=d%+1
  604.         IF LEFT$(i$(d%),1)=CHR$(20) REM line>255...
  605.           b%=b%+1 REM ...so it's 2 fields
  606.         ENDIF
  607.       ENDWH
  608.       b%=17
  609.       WHILE b%>d% REM copy the fields down
  610.         i$(b%)=i$(b%-1) :b%=b%-1 
  611.       ENDWH
  612.       i$(d%)="" REM and make an empty field
  613.       A.a$=i$(1) :A.b$=i$(2) :A.c$=i$(3) :A.d$=i$(4)
  614.       A.e$=i$(5) :A.f$=i$(6) :A.g$=i$(7) :A.h$=i$(8)
  615.       A.i$=i$(9) :A.j$=i$(10) :A.k$=i$(11) :A.l$=i$(12)
  616.       A.m$=i$(13) :A.n$=i$(14) :A.o$=i$(15) :A.p$=i$(16)
  617.       A.q$=i$(17)
  618.     ELSE
  619.       PRINT "has too many fields"
  620.       PRINT "Press a key..." :GET
  621.     ENDIF
  622.     UPDATE :FIRST
  623.     a%=a%+1
  624.   ENDWH :CLOSE
  625. ENDIF
  626. ENDP
  627.  
  628. PROC bounce:
  629.   LOCAL posX%,posY%,changeX%,changeY%,k%
  630.   LOCAL scrx%,scry%,info%(10)
  631.   SCREENINFO info%()
  632.   scrx%=info%(3) :scry%=info%(4)
  633.   posX%=1  :posY%=1
  634.   changeX%=1 :changeY%=1
  635.   DO
  636.     posX%=posX%+changeX%
  637.     posY%=posY%+changeY%
  638.     IF posX%=1 OR posX%=scrx%
  639.       changeX%=-changeX%
  640.       REM at edge ball changes direction
  641.       BEEP 2, 600 REM low beep
  642.     ENDIF
  643.     IF posY%=1 or posY%=scry% REM same for y
  644.       changeY%=-changeY%
  645.       BEEP 2, 200 REM high beep
  646.     ENDIF
  647.     AT posX%,posY% :PRINT "0";
  648.     PAUSE 2   REM Try changing this
  649.     AT posX%,posY% :PRINT " ";
  650.     REM removes old `0' character
  651.     k%=KEY
  652.   UNTIL k%
  653. ENDP
  654.  
  655. PROC circle:
  656.   LOCAL a%(963),c&,d%,x&,y&,r&,h,y%,y1%,c2%
  657.   dINIT "Draw a circle"
  658.   x&=240 :dLONG x&,"Centre x pos",0,479
  659.   y&=80 :dLONG y&,"Centre y pos",0,159
  660.   r&=20 :dLONG r&,"Radius",1,120
  661.   h=1 :dFLOAT h,"Relative height",0,999
  662.   IF DIALOG
  663.     a%(1)=x&+r& :a%(2)=y& :a%(3)=4*r&
  664.     c&=1 :d%=2*r& :y1%=0
  665.     WHILE c&<=d%
  666.       c2%=c&*2 :y%=-SQR(r&*c2%-c&**2)*h
  667.       a%(2+c2%)=-2 :a%(3+c2%)=y%-y1%
  668.       y1%=y% :c&=c&+1
  669.     ENDWH
  670.     c&=1
  671.     WHILE c&<=d%
  672.       c2%=c&*2 :y%=SQR(r&*c2%-c&**2)*h
  673.       a%(2+a%(3)+c2%)=2 :a%(3+a%(3)+c2%)=y%-y1%
  674.       y1%=y% :c&=c&+1
  675.     ENDWH
  676.     gPOLY a%()
  677.   ENDIF
  678. ENDP
  679.  
  680. PROC circlef:
  681.   LOCAL c&,d%,x&,y&,r&,h,y%
  682.   dINIT "Draw a filled circle"
  683.   x&=240 :dLONG x&,"Centre x pos",0,479
  684.   y&=80 :dLONG y&,"Centre y pos",0,159
  685.   r&=20 :dLONG r&,"Radius",1,120
  686.   h=1 :dFLOAT h,"Relative height",0,999
  687.   IF DIALOG
  688.     c&=1 :d%=2*r& :gAT x&-r&,y& :gLINEBY 0,0
  689.     WHILE c&<=d%
  690.       y%=-SQR(r&*c&*2-c&**2)*h
  691.       gAT x&-r&+c&,y&-y% :gLINEBY 0,2*y%
  692.       c&=c&+1
  693.     ENDWH
  694.   ENDIF
  695. ENDP
  696.  
  697. PROC tzoom:
  698.   STATUSWIN OFF   REM no status window
  699.   zoom:           REM display with zooming
  700.   STATUSWIN ON,2  REM large status window
  701.   zoom:
  702.   STATUSWIN ON,1  REM and small
  703.   zoom:
  704. ENDP
  705.  
  706. PROC zoom:
  707.   LOCAL font%(3),font$(3,20),style%(3)
  708.   LOCAL g%,km%,zoom%
  709.   zoom%=1
  710.   font%(1)=13 :font$(1)="(Mono 6x6)" :style%(1)=0  
  711.   font%(2)=4  :font$(2)="(Mono 8x8)" :style%(2)=0  
  712.   font%(3)=12 :font$(3)="(Swiss 16)" :style%(3)=16 
  713.   g%=%z+$200
  714.   DO
  715.     IF g%=%z+$200
  716.       IF km% AND 2        REM Shift-PSION-Z
  717.         zoom%=zoom%-1
  718.         IF zoom%<1 :zoom%=3 :ENDIF
  719.       ELSE                REM PSION-Z
  720.         zoom%=zoom%+1
  721.         IF zoom%>3 :zoom%=1 :ENDIF
  722.       ENDIF
  723.       FONT font%(zoom%),style%(zoom%)
  724.       PRINT "Font=";font%(zoom%),font$(zoom%),
  725.       PRINT "Style=";style%(zoom%)
  726.       dispinfo:
  727.       PRINT rept$("1234567890",15)
  728.       gBORDER 0
  729.     ENDIF
  730.     g%=GET
  731.     km%=KMOD
  732.   UNTIL g%=27
  733. ENDP
  734.  
  735. PROC dispinfo:
  736.   LOCAL scrInfo%(10)
  737.   SCREENINFO scrInfo%()
  738.   PRINT "Left margin=";scrInfo%(1),
  739.   AT 17,2 :PRINT "Top margin=";scrInfo%(2)
  740.   PRINT "Screen width=";scrInfo%(3)
  741.   AT 17,3 :PRINT "Screen height=";scrInfo%(4)
  742.   PRINT "Char width=";scrInfo%(7)
  743.   AT 17,4 :PRINT "Line height=";scrInfo%(8)
  744. ENDP
  745.  
  746. PROC animate:
  747.   LOCAL id%(5),i%,j%,s$(5,10),w%,h%
  748.   w%=16 :h%=28 REM example width and height
  749.   s$(1)="one" :s$(2)="two" :s$(3)="three"
  750.   s$(4)="four" :s$(5)="five" :j%=1
  751.   WHILE j%<6
  752.     i%=gLOADBIT(s$(j%))
  753.     id%(j%)=gCREATE(0,0,w%,h%,0)
  754.     gCOPY i%,0,0,w%,h%,3
  755.     gCLOSE i% :j%=j%+1
  756.   ENDWH
  757.   i%=0 :gORDER 1,9
  758.   DO
  759.     j%=(i%-5*(i%/5))+1 REM (i% MOD 5)+1
  760.     gVISIBLE OFF REM previous window
  761.     gUSE id%(j%) REM new window
  762.     gSETWIN i%,20 REM position it
  763.     gORDER id%(j%),1 REM make foreground
  764.     gVISIBLE ON REM make visible
  765.     i%=i%+1 :PAUSE 2
  766.   UNTIL KEY OR (i%>(480-w%)) REM screen edge
  767. ENDP
  768.  
  769. PROC main:
  770.   local ret%,sndHand%
  771.   ret%=IOOPEN(sndHand%,"SND:",-1) REM open the device
  772.   if ret%<0
  773.     print "Failed to start"
  774.     print err$(err)
  775.     get
  776.   else
  777.     icecream:(sndHand%)
  778.     ioclose(sndHand%)
  779.   endif 
  780. ENDP
  781.  
  782. PROC icecream:(sndHand%)
  783.   local notes1%(4),notes2%(14)
  784.   local s1stat%,len1%,len2%
  785.   REM define 1st voice
  786.   notes1%(1)=1048  :notes1%(2)=96 REM freq, duration
  787.   notes1%(3)=524   :notes1%(4)=48
  788.   len1%=2 REM number of notes in voice 1
  789.   REM define 2nd voice
  790.   notes2%(1)=1048  :notes2%(2)=16
  791.   notes2%(3)=1320  :notes2%(4)=16
  792.   notes2%(5)=1568  :notes2%(6)=16
  793.   notes2%(7)=2092  :notes2%(8)=16
  794.   notes2%(9)=1568  :notes2%(10)=16
  795.   notes2%(11)=1320 :notes2%(12)=16
  796.   notes2%(13)=1048 :notes2%(14)=48
  797.   len2%=7  REM number of notes in voice 2
  798.   IOC(sndhand%,1,s1stat%,notes1%(),len1%)
  799.     REM voice 1 asynchronous
  800.   IOW(sndHand%,2,notes2%(),len2%) REM voice 2 synchronous
  801.   IOWAITSTAT s1stat%
  802. ENDP
  803.  
  804. 10: Error handling
  805.  
  806. 11: Advanced topics
  807.  
  808. APP myapp0
  809.   TYPE $1000
  810.   ICON "\opd\me"
  811. ENDA
  812.  
  813. PROC start:
  814.   GLOBAL a%(6),k%
  815.   STATUSWIN ON :FONT 11,16
  816.   PRINT "Q to Quit"
  817.   PRINT " or press Delete in"
  818.   PRINT " the System screen"
  819.   DO
  820.     k%=getk%:
  821.     PRINT CHR$(k%);
  822.   UNTIL (k% AND $ffdf)=%Q  REM Quick way to do uppercase
  823. ENDP
  824.  
  825. PROC getk%:
  826.   DO
  827.     GETEVENT a%()
  828.     IF a%(1)=$404
  829.       IF LEFT$(GETCMD$,1)="X"
  830.         endit:
  831.       ENDIF
  832.     ENDIF
  833.   UNTIL a%(1)<256
  834.   RETURN a%(1)
  835. ENDP
  836.  
  837. PROC endit:
  838.   STOP
  839. ENDP
  840.  
  841. APP myapp3
  842.   TYPE $1003
  843.   ICON "\opd\me"
  844. ENDA
  845.  
  846. PROC start:
  847.   GLOBAL a%(6),k%,w$(128)
  848.   STATUSWIN ON :FONT 11,16 :w$=CMD$(2)
  849.   fset:(CMD$(3))
  850.   PRINT "Q to Quit"
  851.   PRINT " or press Delete in"
  852.   PRINT "the System screen"
  853.   PRINT " or create/swap files in"
  854.   PRINT "the System screen"
  855.   DO
  856.     k%=getk%:
  857.     PRINT CHR$(k%);
  858.   UNTIL (k% AND $ffdf)=%Q
  859. ENDP
  860.  
  861. PROC getk%:
  862.   LOCAL t$(1)
  863.   DO
  864.     GETEVENT a%()
  865.     IF a%(1)=$404
  866.       w$=GETCMD$
  867.       t$=LEFT$(w$,1)
  868.       w$=MID$(w$,2,128)
  869.       IF t$="X"
  870.         endit:
  871.       ELSEIF t$="C" OR t$="O"
  872.         TRAP CLOSE
  873.         IF ERR
  874.           CLS :PRINT ERR$(ERR)
  875.           GET :CONTINUE
  876.         ENDIF
  877.         fset:(t$)
  878.       ENDIF
  879.     ENDIF
  880.   UNTIL a%(1)<256
  881.   RETURN a%(1)
  882. ENDP
  883.  
  884. PROC fset:(t$)
  885.   LOCAL p%(6)
  886.   IF t$="C"
  887.     TRAP DELETE w$  REM SYS.SCREEN DOES ANY "OVERWRITE?"
  888.     TRAP CREATE w$,A,A$
  889.   ELSEIF t$="O"
  890.     TRAP OPEN w$,A,A$
  891.   ENDIF
  892.   IF ERR
  893.     CLS :PRINT ERR$(ERR)
  894.     GET :STOP
  895.   ENDIF
  896.   SETNAME w$
  897. ENDP
  898.  
  899. PROC endit:
  900.   STOP
  901. ENDP
  902.  
  903. PROC myicon:
  904.   gCREATE(0,0,48,48,1,1)
  905.   gBORDER $200
  906.   gAT 6,28
  907.   gPRINT "me!"
  908.   gSAVEBIT "me"
  909. ENDP
  910.  
  911. PROC beepon:
  912. local a%(6)
  913. print "Hello"
  914. call($6c8d) :gupdate
  915. while 1
  916.   do
  917.     getevent a%()
  918.     if a%(1)=$404 :stop :endif :REM closedown
  919.   until a%(1)=$403 :REM machine ON
  920.   call($198d,0,0) :gupdate
  921.   beep 5,300 :pause 10 :beep 5,500
  922.   call($198d,100,0) :gupdate
  923. endwh
  924. ENDP
  925.  
  926. CACHEHDR ADDR(hdr%())
  927. IF hdr%(10)=0
  928.   PRINT "No cache created yet"
  929.   RETURN
  930. ENDIF
  931. IF hdr%(8)=0                    rem MRU zero?
  932.   PRINT "None cached currently"
  933.   RETURN
  934. ENDIF
  935. rec%(1)=0                       rem MRU first
  936. DO
  937.   CACHEREC ADDR(rec%()),rec%(1) rem less recently used proc
  938.   PRINT PEEK$(ADDR(rec%(8))),rec%(7) rem name and size
  939. UNTIL rec%(1)=0
  940.  
  941. PROC sprite:
  942.   LOCAL bit$(6,6),sprId%
  943.   crBits:                  REM create bitmap files
  944.   gAT gWIDTH/2,0
  945.   gFILL gWIDTH/2,gHEIGHT,0 REM fill half of screen
  946.   sprId%=CREATESPRITE
  947.   bit$(1)="" :bit$(2)=""
  948.   bit$(3)="cross"    REM black cross, pixels inverted
  949.   bit$(4)="" :bit$(5)="" :bit$(6)=""
  950.   APPENDSPRITE 5,bit$(),0,0 REM cross for half a second
  951.   bit$(1)="" :bit$(2)="" :bit$(3)=""
  952.   bit$(4)="" :bit$(5)="" :bit$(6)=""
  953.   APPENDSPRITE 5,bit$(),0,0 REM blank for half a second
  954.   DRAWSPRITE gWIDTH/2-5,gHEIGHT/2-5
  955.                             REM animate the sprite
  956.   BUSY "flash cross, c",3   REM no offset
  957.                             REM ('c' for central)
  958.   GET
  959.   bit$(3)="box"             REM black box, pixels inverted
  960.   CHANGESPRITE 2,5,bit$(),0,0        REM in 2nd bitmap-set
  961.   BUSY "cross/box, c/c",3   REM central/central
  962.   GET
  963.   CHANGESPRITE 2,5,bit$(),40,0
  964.                             REM offset by 40 pixels right
  965.   BUSY "cross/box, c/40",3  REM central/40
  966.   GET
  967.   bit$(3)=""                REM Remove the cross in set 1
  968.   CHANGESPRITE 1,3,bit$(),0,0 REM display for 3/10 seconds
  969.   BUSY "flash box, 40",3    REM box at offset 40 still
  970.   GET
  971.   bit$(3)="cross"
  972.   CHANGESPRITE 1,5,bit$(),0,0
  973.                             REM cross centralised - set 1
  974.   bit$(3)="box"
  975.   CHANGESPRITE 2,5,bit$(),0,0
  976.                             REM box centralised - set 2
  977.   BUSY "Escape quits"
  978.   DO
  979.     POSSPRITE RND*(gWIDTH-11),RND*(gHEIGHT-11)
  980.                             REM move sprite randomly
  981.     PAUSE -20               REM once a second
  982.   UNTIL KEY = 27
  983.   CLOSESPRITE sprId%
  984. ENDP
  985.  
  986. PROC crBits:
  987.   REM create bitmap files if they don't exist
  988.   IF NOT EXIST("cross.pic") OR NOT EXIST("box.pic")
  989.     gCREATE(0,0,11,11,1,1)
  990.     gAT 5,0 :gLineBy 0,11
  991.     gAT 0,5 :gLineBy 11,0
  992.     gSAVEBIT "cross"
  993.     gCLS
  994.     gAT 0,0
  995.     gBOX gWIDTH,gHEIGHT
  996.     gSAVEBIT "box"
  997.     gCLOSE gIDENTITY
  998.   ENDIF
  999. ENDP
  1000.  
  1001. PROC ioType:
  1002.   LOCAL ret%,fName$(128),txt$(255),address%
  1003.   LOCAL handle%,mode%,k%
  1004.   PRINT "Filename?", :INPUT fName$ :  CLS
  1005.   mode%= $0400 OR $0020
  1006.   REM open=$0000, text=$0020, share=$0400
  1007.   ret%=IOOPEN(handle%,fName$,mode%)
  1008.   IF ret%<0
  1009.     showErr:(ret%)
  1010.     RETURN
  1011.   ENDIF  
  1012.   address%=ADDR(txt$)
  1013.   WHILE 1
  1014.     k%=KEY
  1015.     IF k%    REM if keypress
  1016.       IF k%=27 REM Esc pressed
  1017.         RETURN
  1018.       REM otherwise wait for a key
  1019.       ELSEIF GET=27
  1020.          RETURN REM Esc pressed
  1021.       ENDIF
  1022.     ENDIF
  1023.     ret%=IOREAD(handle%,address%+1,255)
  1024.     IF ret%<0
  1025.       IF ret%<>-36 REM NOT EOF
  1026.         showErr:(ret%)
  1027.       ENDIF
  1028.       BREAK
  1029.     ELSE
  1030.       POKEB address%,ret%
  1031.       REM leading byte count
  1032.       PRINT txt$
  1033.     ENDIF
  1034.   ENDWH
  1035.   ret%=IOCLOSE(handle%)
  1036.   IF ret%
  1037.     showErr:(ret%)
  1038.   ENDIF
  1039.   PAUSE -100 :KEY
  1040. ENDP
  1041.  
  1042. PROC showErr:(val%)
  1043.   PRINT "Error",val%,err$(val%)
  1044.   GET
  1045. ENDP
  1046.  
  1047. PROC iotest:
  1048. GLOBAL x1%,x2%,y1%,y2%
  1049. LOCAL i%,h$(2),a$(5)
  1050.   x1%=2 :y1%=2
  1051.   x2%=25 :y2%=5 REM our test screensize
  1052.   SCREEN x2%-x1%,y2%-y1%,x1%,y1%
  1053.   AT 1,1
  1054.   PRINT "Text window IO test"
  1055.   PRINT "Psion-Esc quits"
  1056.   h$="cr" REM our hot-keys
  1057.   DO
  1058.     i%=GET
  1059.     IF i%=$122 REM Menu key
  1060.       mINIT
  1061.       mCARD "Set","Rect",%r
  1062.       mCARD "Sense","Cursor",%c
  1063.       i%=MENU
  1064.       IF i% AND INTF(LOC(h$,CHR$(i%)))
  1065.          a$="proc"+chr$(i%)
  1066.         @(a$): 
  1067.       ENDIF
  1068.     ELSEIF i% AND $200 REM hot-key
  1069.       i%=(i%-$200)
  1070.       i%=LOC(h$,CHR$(i%)) REM One of ours?
  1071.       IF i%
  1072.          a$="proc"+MID$(h$,i%,1)
  1073.         @(a$):
  1074.       ENDIF REM ignore other weird keypresses
  1075.     ELSE REM some other key, so return it
  1076.       PRINT CHR$(i%);
  1077.     ENDIF
  1078.   UNTIL 0
  1079. ENDP
  1080.  
  1081. PROC procc:
  1082.   LOCAL a&
  1083.   a&=iocurs&:
  1084.   PRINT "x";1+(a& AND &ffff);
  1085.   PRINT "y";1+(a&/&10000);
  1086. ENDP
  1087.  
  1088. PROC procr:
  1089.   LOCAL xx1%,yy1%,xx2%,yy2%
  1090.   LOCAL xx1&,yy1&,xx2&,yy2&
  1091.   dINIT "Clear rectangle"
  1092.   dLONG xx1&,"Top left x",1,x2%-x1%
  1093.   dLONG yy1&,"Top left y",1,y2%-y1%
  1094.   dLONG xx2&,"Bottom left x",2,x2%-x1%
  1095.   dLONG yy2&,"Bottom left y",2,y2%-y1%
  1096.   IF DIALOG
  1097.     xx1%=xx1&-1 :xx2%=xx2&-1
  1098.     yy1%=yy1&-1 :yy2%=yy2&-1
  1099.     iorect:(xx1%,yy1%,xx2%,yy2%)
  1100.   ENDIF
  1101. ENDP
  1102.  
  1103. PROC iocurs&:
  1104.   LOCAL a%(4),a&
  1105.   REM don't change the order of these!
  1106.   a%(1)=x1% :a%(2)=y1%
  1107.   a%(3)=x2% :a%(4)=y2%
  1108.   IOW(-2,8,a%(),a%()) REM 2nd a% is ignored
  1109.   RETURN a&
  1110. ENDP
  1111.  
  1112. PROC iorect:(xx1%,yy1%,xx2%,yy2%)
  1113.   LOCAL i%,a%(6)
  1114.   i%=2 :REM "clear rect" option
  1115.   a%(1)=xx1% :a%(2)=yy1%
  1116.   a%(3)=xx2% :a%(4)=yy2%
  1117.   IOW(-2,7,i%,a%())
  1118. ENDP 
  1119.  
  1120. PROC alm:
  1121.   LOCAL h%,a&(2),a$(64),b$(65),d&,t&,t2&,a%,r%,s%
  1122.   r%=IOOPEN(h%,"ALM:",0)
  1123.   IF r%<0 :RAISE r% :ENDIF
  1124.   d&=DAYS(DAY,MONTH,YEAR) REM today
  1125.   t&=DATETOSECS(1970,1,1,HOUR,MINUTE,0)
  1126.   DINIT "Set alarm"
  1127.   DTIME t&,"Time",0,0,DATETOSECS(1970,1,1,23,59,59)
  1128.   DDATE d&,"Date",d&,DAYS(31,12,2049)
  1129.   DTIME t2&,"Alarm advance time",2,0,86399
  1130.   DEDIT a$,"Message"
  1131.   IF DIALOG
  1132.     a&(2)=86400*(d&-25567)+t&
  1133.     a&(1)=a&(2)-t2&
  1134.     b$=a$+CHR$(0) REM zero-terminate the string
  1135.     IOC(h%,2,s%,a&(),#UADD(ADDR(b$),1))
  1136.   ENDIF
  1137.   IOCLOSE(h%)
  1138. ENDP
  1139.  
  1140. PROC dtmf:
  1141.   LOCAL h%,a$(24),b$(25),z%,r%,a%(2)
  1142.   r%=IOOPEN(h%,"SND:",0)
  1143.   IF r%<0 :RAISE r% :ENDIF
  1144.   dINIT
  1145.   dEDIT a$,"Dial"
  1146.   IF DIALOG
  1147.     a%(1)=8+(256*8)
  1148.     a%(2)=48
  1149.     b$=a$+CHR$(0)
  1150.     r%=IOW(h%,10,#UADD(ADDR(b$),1),a%())
  1151.     IF r%<0 :RAISE r% :ENDIF
  1152.   ENDIF
  1153.   r%=IOCLOSE(h%)
  1154.   IF r%<0 :RAISE r% :ENDIF
  1155. ENDP
  1156.  
  1157. PROC recorda:(pstat%,inname$,size%)
  1158.   LOCAL name$(128)
  1159.   name$=inname$+chr$(0)
  1160.   CALL($2186,UADD(ADDR(name$),1),size%,0,0,pstat%)
  1161. ENDP
  1162.  
  1163. PROC recordc:
  1164.   CALL($2386)
  1165. ENDP
  1166.  
  1167. PROC recordw%:(inname$,size%)
  1168.   LOCAL name$(128),p%,ret%
  1169.   p%=PEEKW($1c)+6  REM address of saved flags after CALL
  1170.   name$=inname$+chr$(0)
  1171.   ret%=CALL($2286,UADD(ADDR(name$),1),size%)
  1172.   IF PEEKW(p%) AND 1     REM carry set for error
  1173.     RETURN ret% OR $FF00 REM return error
  1174.   ENDIF
  1175. ENDP
  1176.  
  1177. PROC playa:(pstat%,inname$,ticks%,vol%)
  1178.   LOCAL name$(128)
  1179.   name$=inname$+chr$(0)
  1180.   CALL($1E86,UADD(ADDR(name$),1),ticks%,vol%,0,pstat%)
  1181. ENDP
  1182.  
  1183. PROC playc:
  1184.   CALL($2086)
  1185. ENDP
  1186.  
  1187. PROC playw%:(inname$,ticks%,vol%)
  1188.   LOCAL name$(128),p%,ret%
  1189.   p%=PEEKW($1c)+6 REM address of saved flags after CALL
  1190.   name$=inname$+chr$(0)
  1191.   ret%=CALL($1F86,UADD(ADDR(name$),1),ticks%,vol%)
  1192.   IF PEEKW(p%) AND 1     REM carry set for error
  1193.     RETURN ret% OR $FF00 REM return error
  1194.   ENDIF
  1195. ENDP
  1196.  
  1197. PROC record:(file$,time%)
  1198.   LOCAL sstat%,kstat%,key%(4),size%,ret%,signals%
  1199.   size%=time%*4
  1200.   recorda:(ADDR(sstat%),file$,size%) REM async record
  1201.   IOC(-2,1,kstat%,key%())            REM async key read
  1202.   WHILE 1
  1203.     IOWAIT  REM wait for recording to complete, or a key
  1204.     IF sstat%<>-46         REM if sound no longer pending
  1205.       IOCANCEL(-2)         REM cancel key read
  1206.       IOWAITSTAT kstat%    REM wait for cancellation
  1207.       IF sstat%<0
  1208.         gIPRINT "Error recording:"+err$(sstat%)
  1209.       ENDIF
  1210.       BREAK
  1211.     ELSEIF kstat%<>-46     REM else if key pressed
  1212.       recordc:             REM cancel record
  1213.       IOWAITSTAT sstat%    REM wait for cancellation
  1214.       gIPRINT "Cancelled"
  1215.       BREAK
  1216.     ELSE
  1217.       REM some async request made outside this PROC
  1218.       signals%=signals%+1  REM save it for later
  1219.     ENDIF
  1220.   ENDWH
  1221.   WHILE signals%
  1222.     IOSIGNAL               REM put back foreign signals
  1223.     signals%=signals%-1
  1224.   ENDWH
  1225. ENDP
  1226.  
  1227. PROC dbfDesc:
  1228.   LOCAL ax%,bx%,cx%,dx%,si%,di%
  1229.   LOCAL info%(4),len%,psrc%,pdest%
  1230.   ODBINFO info%()
  1231.   bx%=PEEKW(info%(2))   REM handle of logical file B
  1232.   ax%=$1700             REM DbfDescRecordRead
  1233.   IF OS($d8,ADDR(ax%)) and 1
  1234.     RETURN ax% OR $ff00 REM return the error
  1235.   ENDIF
  1236.   REM the descriptive record has length ax%
  1237.   REM and is at address peekW(uadd(info%(2),8))
  1238.   IF  ax%=0
  1239.     RETURN 0            REM no DescRecord
  1240.   ENDIF
  1241.   len%=ax%+2            REM length of the descriptive
  1242.                         REM record read + 2-byte header
  1243.   psrc%=PEEKW(uadd(info%(2),8))
  1244.   pdest%=PEEKW(uadd(info%(3),8))
  1245.   CALL($a1,0,len%,0,psrc%,pdest%)
  1246.                         REM copy to C's buffer
  1247.   cx%=len%
  1248.   bx%=PEEKW(info%(3))   REM handle of logical file C
  1249.   ax%=$1800             REM DbfDescRecordWrite
  1250.   IF OS($d8,ADDR(ax%)) and 1
  1251.     RETURN ax% OR $ff00
  1252.   ENDIF
  1253.   RETURN 0              REM success
  1254. ENDP
  1255.  
  1256. local pcell% rem pointer to cell
  1257. LOCAL pcelln%        rem new pointer to cell
  1258. LOCAL p%             rem general pointer
  1259. LOCAL n%             rem general integer
  1260. ONERR e1
  1261. pcell%=ALLOC(2+2*8)  rem holds an integer and
  1262.                      rem 2 8-byte floats initially
  1263. IF pcell%=0
  1264.   RAISE -10          rem out of memory; go to e1::
  1265. ENDIF
  1266. POKEW pcell%,2       rem store integer 2 at start of cell
  1267.                      rem ie. no. of floats
  1268. POKEF UADD(pcell%,2),2.72     rem store float 2.72
  1269. POKEF UADD(pcell%,10),3.14    rem store float 3.14
  1270. ...
  1271. pcelln%=REALLOC(pcell%,2+3*8) rem space for 3rd float
  1272. IF pcelln%=0
  1273.   RAISE -10                   rem out of memory
  1274. ENDIF
  1275. pcell%=pcelln%                rem use new cell address
  1276. n%=PEEKW(pcell%)              rem no. of floats in cell
  1277. POKEF UADD(pcell%,2+n%*8),1.0 rem 1.0 after 3.14
  1278. POKEW pcell%,n%+1             rem one more float in cell
  1279. ...
  1280. pcelln%=ADJUSTALLOC(pcell%,2,8) rem open gap before 2.72
  1281. IF pcell%=0
  1282.   RAISE -10              rem out of memory
  1283. ENDIF
  1284. pcell%=pcelln%           rem use new cell address
  1285. POKEF UADD(pcell%,2),1.0 rem store 1.0 before 2.72
  1286. POKEW pcell%,4           rem 4 floats in cell now
  1287. ...
  1288. p%=UADD(pcell%,LENALLOC(pcell%)) rem byte after cell end
  1289. p%=USUB(p%,8)              rem address of final float
  1290. POKEF p%,90000.1           rem overwrite with 90000.1
  1291. RAISE 0                    rem clear ERR value
  1292. e1::
  1293. FREEALLOC pcell%           rem free any cell created
  1294. IF err<>0
  1295.   ...                      rem display error message etc
  1296. ENDIF
  1297. RETURN ERR
  1298.  
  1299. 12: Overview
  1300.  
  1301. 13: Alphabetic listing
  1302.  
  1303. PROC scale:
  1304. LOCAL freq,n%
  1305. REM n% relative to middle A
  1306. n%=3 REM start at middle C
  1307. WHILE n%<16
  1308.  freq=440*2**(n%/12.0)
  1309.  REM middle A = freq 440Hz
  1310.  BEEP 8,512000/freq-1.0
  1311.  n%=n%+1
  1312.  IF n%=4 OR n%=6 OR n%=9 OR n%=11 OR n%=13
  1313.   n%=n%+1
  1314.  ENDIF
  1315. ENDWH
  1316. ENDP
  1317.  
  1318. PROC Birthday:
  1319.  LOCAL d&,m&,y&,dWk%
  1320.  DO
  1321.   dINIT
  1322.   dTEXT "","Date of birth",2
  1323.   dTEXT "","eg 23 12 1963",$202
  1324.   dLONG d&,"Day",1,31
  1325.   dLONG m&,"Month",1,12
  1326.   dLONG y&,"Year",1900,2155
  1327.   IF DIALOG=0 :BREAK :ENDIF
  1328.   dWk%=DOW(d&,m&,y&)
  1329.   CLS :PRINT DAYNAME$(dWk%),
  1330.   PRINT d&,m&,y&
  1331.   dINIT
  1332.   dTEXT "","Again?",$202
  1333.   dBUTTONS "No",%N,"Yes",%Y
  1334.  UNTIL DIALOG<>%y
  1335. ENDP 
  1336.  
  1337. PROC deadline:
  1338.  LOCAL a%,b%,c%,deadlin&
  1339.  LOCAL today&,togo%
  1340.  PRINT "What day? (1-31)"
  1341.  INPUT a%
  1342.  PRINT "What month? (1-12)"
  1343.  INPUT b%
  1344.  PRINT "What year? (19??)"
  1345.  INPUT c%
  1346.  deadlin&=DAYS(a%,b%,1900+c%)
  1347.  today&=DAYS(DAY,MONTH,YEAR)
  1348.  togo%=deadlin&-today&
  1349.  PRINT togo%,"days to go"
  1350.  GET
  1351. ENDP
  1352.  
  1353. PROC dir:
  1354.  LOCAL d$(128)
  1355.  d$=DIR$("M:\DAT\*.DBF")
  1356.  WHILE d$<>""
  1357.   PRINT d$
  1358.   d$=DIR$("")
  1359.  ENDWH
  1360.  GET
  1361. ENDP
  1362.  
  1363. DO 
  1364. AT 10,5 :PRINT "Calc:",
  1365. TRAP INPUT n$
  1366. IF n$="" :CONTINUE :ENDIF
  1367. IF ERR=-114 :BREAK :ENDIF
  1368. CLS :AT 10,4
  1369. PRINT n$;"=";EVAL(n$)
  1370. UNTIL 0
  1371.  
  1372. PROC gamma:(v)
  1373.  LOCAL c
  1374.  c=3E8
  1375.  RETURN 1/SQR(1-(v*v)/(c*c))
  1376. ENDP
  1377.  
  1378. PROC modifier:
  1379. LOCAL k%,mod%
  1380. PRINT "Press a key" :k%=GET
  1381. CLS :mod%=KMOD
  1382. PRINT "Key code",k%,"with"
  1383. IF mod%=0
  1384.  PRINT "no modifier"
  1385. ENDIF
  1386. IF mod% AND 2
  1387.  PRINT "Shift down"
  1388. ENDIF
  1389. IF mod% AND 4
  1390.  PRINT "Control down"
  1391. ENDIF
  1392. IF mod% AND 8
  1393.  PRINT "Psion down"
  1394. ENDIF
  1395. IF mod% AND 16
  1396.  PRINT "Caps Lock on"
  1397. ENDIF
  1398. ENDP
  1399.  
  1400. PROC SEQ:
  1401. LOCAL g$(1)
  1402. WHILE 1
  1403.  PRINT "S: set seed to 1"
  1404.  PRINT "Q: quit"
  1405.  PRINT "other key: continue"
  1406.  g$=UPPER$(GET$)
  1407.  IF g$="Q"
  1408.   BREAK
  1409.  ELSEIF g$="S"
  1410.   PRINT "Setting seed to 1"
  1411.   RANDOMIZE 1
  1412.   PRINT "First random no:"
  1413.  ELSE
  1414.   PRINT "Next random no:"
  1415.  ENDIF
  1416.  PRINT RND
  1417. ENDWH
  1418. ENDP
  1419.  
  1420. PROC rectest:
  1421. LOCAL n$(20)
  1422. OPEN "name",A,name$
  1423. PRINT "Enter name:",
  1424. INPUT n$
  1425. IF RECSIZE<=(1022-LEN(n$))
  1426.  A.name$=n$
  1427.  APPEND
  1428. ELSE
  1429.  PRINT "Won't fit in record"
  1430. ENDIF
  1431. ENDP
  1432.  
  1433. PROC rndvals:
  1434. LOCAL i%
  1435. PRINT "Random test values:"
  1436. DO
  1437.  PRINT RND
  1438.  i%=i%+1
  1439.  GET
  1440. UNTIL i%=10
  1441. ENDP
  1442.  
  1443. PROC trivial:
  1444. LOCAL t%(2),u%,ax%
  1445.  t%(1)=$c032  REM xor al,al
  1446.  t%(2)=$cb    REM retf
  1447.  ax%=$1ab
  1448.  u%=usr(addr(t%(1)),ax%,0,0,0)
  1449.  REM returns (ax% AND $FF00)
  1450.  PRINT u% REM 256 ($100)
  1451.  GET
  1452. ENDP
  1453.  
  1454. A: Summary for experienced OPL users
  1455.  
  1456. proc slowdn:
  1457. local i%,j
  1458. print "Slow down S3a"
  1459. call($138b) rem "unmark as active"
  1460. while 1
  1461.   i%=10 :j=j+1
  1462.   while i% :i%=i%-1 :endwh
  1463.   if j=300000
  1464.     j=0 :pause 2
  1465.   else
  1466.     pause 1
  1467.   endif
  1468. endwh
  1469. endp
  1470.  
  1471. PROC scrinfo:(pinfo%)
  1472.   SCREENINFO #pinfo%
  1473. ENDP
  1474.  
  1475. PROC font:(font%,style%)
  1476.   FONT font%,style%
  1477. ENDP
  1478.  
  1479. LOCAL err%,info%(10),...
  1480.   TRAP LOADM "S3aprocs"
  1481.   IF ERR=0 OR ERR=-104
  1482.       rem if not 'Incompatible translator' error
  1483.       rem or if already loaded, then in normal mode
  1484.     err%=ERR
  1485.     font%=$9a           rem system font
  1486.     font:(font%,16)     rem mono-ised style 
  1487.     scrInfo:(ADDR(info%))
  1488.     marginX%=info%(1)   rem pixels from left of screen
  1489.     marginY%=info%(2)   rem pixels from top of screen
  1490.     chrW%=info%(7)      rem character width in pixels
  1491.     chrH%=info%(8)      rem character height in pixels
  1492.     screenX%=gWIDTH/chrW%       rem char screen width
  1493.     screenY%=(gHEIGHT+1)/chrH%  rem char screen height
  1494.     IF err%-104       rem if loaded here
  1495.       UNLOADM "S3aprocs"
  1496.     ENDIF
  1497.   ELSE                  rem else on Series 3 or
  1498.                         rem in compatibility mode
  1499.                         rem so just use fixed values
  1500.     marginX%=0          rem no margins on Series 3
  1501.     marginY%=0
  1502.     chrW%=6             rem default console char width
  1503.     chrH%=9             rem ...and height
  1504.     screenX%=40         rem character columns
  1505.     screenY%=9          rem character rows
  1506.     font%=1             rem font ID = 1 on Series 3
  1507.   ENDIF
  1508.  
  1509. B: Operators and logical expressions
  1510.  
  1511. C: Serial/parallel ports and printing
  1512.  
  1513. PROC prints:
  1514.   OPEN "clients",A,a$
  1515.   LOPEN "PAR:A"
  1516.   PRINT "Printing..."
  1517.   DO
  1518.     IF LEN(A.a$)
  1519.       LPRINT A.a$
  1520.     ENDIF
  1521.     NEXT
  1522.   UNTIL EOF
  1523.   LPRINT CHR$(12); :LCLOSE
  1524.   PRINT "Finished" :GET
  1525. ENDP
  1526.  
  1527. PROC rsset:(baud%,parity%,data%,stop%,hand%,term&)
  1528.   LOCAL frame%,srchar%(6),dummy%,err%
  1529.   frame%=data%-5
  1530.   IF stop%=2 :frame%=frame% OR 16 :ENDIF
  1531.   IF parity% :frame%=frame% OR 32 :ENDIF
  1532.   srchar%(1)=baud% OR (baud%*256)
  1533.   srchar%(2)=frame% OR (parity%*256)
  1534.   srchar%(3)=(hand% AND 255) OR $1100
  1535.   srchar%(4)=$13
  1536.   POKEL ADDR(srchar%(5)),term&
  1537.   err%=IOW(-1,7,srchar%(1),dummy%)
  1538.   IF err% :RAISE err% :ENDIF
  1539. ENDP
  1540.  
  1541. PROC test:
  1542.   PRINT "Testing port settings"
  1543.   LOPEN "TTY:A"
  1544.   LOADM "rsset"
  1545.   rsset:(8,0,8,1,0,&0)
  1546.   LPRINT "Port OK" :LPRINT
  1547.   PRINT "Finished" :GET
  1548.   LCLOSE
  1549. ENDP
  1550.  
  1551. PROC testread:
  1552.   LOCAL ret%,pbuf%,buf$(255),end%,len%
  1553.   PRINT "Test reading from serial port"
  1554.   LOPEN "TTY:A"
  1555.   LOADM "rsset"
  1556.   REM receive at 2400 without h/shake
  1557.   rsset:(11,0,8,1,0,&04002000) REM Control-Z or CR
  1558.   pBuf%=ADDR(buf$)
  1559.   DO
  1560.     REM read max 255 bytes, after leading count byte
  1561.     len%=255
  1562.     ret%=IOW(-1,1,#UADD(pbuf%,1),len%)
  1563.     POKEB pbuf%,len%   REM len% = length actually read
  1564.                        REM including terminator char
  1565.     end%=LOC(buf$,CHR$(26)) REM non-zero for Control-Z
  1566.     IF ret%<0 and ret%<>-43
  1567.       BEEP 3,500
  1568.       PRINT
  1569.       PRINT "Serial read error: ";ERR$(ret%)
  1570.     ENDIF
  1571.     IF ret%<>-43       REM if received with terminator
  1572.       POKEB pbuf%,len%-1 REM remove terminator
  1573.       PRINT buf$         REM echo with CRLF
  1574.     ELSE
  1575.       PRINT buf$;        REM echo without CRLF
  1576.     ENDIF
  1577.   UNTIL end%
  1578.   PRINT "End of session" :PAUSE -30 :KEY
  1579. ENDP
  1580.  
  1581. D: Character codes
  1582.