home *** CD-ROM | disk | FTP | other *** search
/ AMOS PD CD / amospdcd.iso / sourcecode / general / communev01.amos / communev01.amosSourceCode < prev    next >
Encoding:
AMOS Source Code  |  1992-02-05  |  15.6 KB  |  650 lines
  1. '  Commune V0.01 By Andrew Welsh, Dec 91, Jan 92   
  2. '  SysOp Answer Machine Release 1  
  3. '  Phone Answer Routine By Chris Mackenzie, 1991 
  4. '
  5. '  F1 - Set Up modem manually
  6. '  F2 - Change Palette 
  7. ' F10 - Exit 
  8. '
  9. ' Next Release should see added functions, like a micro host program 
  10. ' with limited file and msg capacity .. + better handling of strings 
  11. ' Release of v0.02 sometime in '92 (Depending on uni workload) 
  12. '
  13. ' Some Procedures are irrelevent to this release .. Ignore them !! 
  14. '
  15. Global DATE$,TIME$,NAME$,PASSWORD$,OK,FMAX,PASS,WIN,BNAME$,SYSNAME$
  16. Global HBAUD$,BAUD$
  17. Global PALNAME$
  18. PALNAME$="BBS/Pal_Palette.DF"
  19. COMM$=Chr$(27)+Chr$(27)+Chr$(27)+"ath0"+Chr$(13)
  20. Screen Open 0,640,260,8,Hires : Flash Off 
  21. If Exist(PALNAME$)
  22.    PAL_LOAD[PALNAME$]
  23. End If 
  24. Get Palette 0
  25. Change Mouse 4
  26. MOUSE_COLOURS_[$BBB,$CCC,$DDD]
  27. Curs Off : Cls 0 : Paper 0
  28. Wind Open 1,0,0,79,8,2
  29. Wind Save 
  30. Border 2,0,2
  31. T$=" Commune V0.01 - (C) 1991, Def Pixel Software "
  32. Title Top T$
  33. Pen 3
  34. Locate 0,1 : Centre "SysOp Answer Machine Release 1"
  35. Pen 2
  36. Wind Open 2,0,65,79,23,1
  37. Border 2,0,2
  38. T$="F10 to Exit"
  39. Title Bottom T$
  40. Wind Save 
  41. '
  42. ' All Config (File/msg/general) routines will go here !! 
  43. _DATE$
  44. If Exist("BBS/Log.DF")
  45.    Append 1,"BBS/Log.DF"
  46. Else 
  47.    Open Out 1,"BBS/Log.DF"
  48. End If 
  49. Print #1," "
  50. Print #1,"--- Commune Session Started ---"
  51. Print #1,DATE$,TIME$
  52. Close 1
  53. _L0AD_CONFIG
  54. '
  55. WIN=1
  56. Wind Open 3,180,25,39,19,2
  57. Curs Off 
  58. Border 1,0,2
  59. Cdown 
  60. Pen 3
  61. X$=Border$("Commune V0.01",2)
  62. Centre X$ : Cdown : Cdown : Cdown 
  63. Pen 2
  64. Centre "(C) 1991, Def Pixel Software" : Cdown 
  65. Cdown : Centre "Written by" : Cdown 
  66. Cdown : Centre "Andrew Welsh" : Cdown 
  67. Cdown : Centre "Using AMOS v1.32" : Cdown 
  68. Cdown : Centre "Thanks to Chris Mackenzie" : Cdown 
  69. Cdown : Centre "For the Answer Routine" : Cdown 
  70. Repeat 
  71.    Inc T
  72. Until Mouse Key=1 or T=19000
  73. Wind Close 
  74. Window 2
  75. WIN=0
  76. Wind Save 
  77. Proc _DATE$
  78. Every 1000 Proc _DATE$
  79. On Error Proc _WHAT
  80. Resume Label MON
  81. '
  82. ' Monitor Modem and Answer Phone 
  83. MON:
  84. _PHONE
  85. Procedure _PHONE
  86.    ' Phone Answer Routine 
  87.    INIT:
  88.    ' First I'll Open a SHARED Serial Channel Like So......
  89.    Print "Setting Up Modem ..."
  90.    Serial Open 0,0,True,False,False : Serial Speed 0,2400 : Serial Bits 0,8,1
  91.    Serial Parity 0,-1
  92.    Serial Send 0,"atz"+Chr$(13)
  93.    Wait 50
  94.    Serial Send 0,"atv0"+Chr$(13)
  95.    Wait 50
  96.    Serial Send 0,"atm0"+Chr$(13)
  97.    Wait 50
  98.    Serial Send 0,"ats0=1"+Chr$(13)
  99.    Wait 50
  100.    Print "Awaiting Call ..."+Chr$(13)
  101.    '  FRED
  102.    '
  103.    ' Then After We Get a Connect Message We'll Open Another Channel 
  104.    ' At The Callers Speed.......
  105.    Do 
  106.       A$=Inkey$ : S=Scancode
  107.       Exit If S=89
  108.       IN$=Serial Input$(0)
  109.       If IN$="0" Then Print "OK"
  110.       If IN$="1" Then CON300
  111.       If IN$="2" Then Print "RING" : Print 
  112.       If IN$="3" Then Print "NO CARRIER"
  113.       If IN$="4" Then Print "ERROR"
  114.       If IN$="5" Then CON1200
  115.       If IN$="10" Then CON2400
  116.       If S=80 Then M0DEMST
  117.       If S=81
  118.          CHANGERGB[0,0,0,2,3]
  119.       End If 
  120.    Loop 
  121.    Print "Exiting .. Commune !"
  122.    Serial Send 0,"ats0=0"+Chr$(13)
  123.    Wait 50
  124.    Serial Close 0
  125.    Wait 50
  126.    Wind Close 
  127.    Wait Vbl 
  128.    Wind Close 
  129.    Screen Close 0
  130.    If Exist("BBS/Log.DF")
  131.       Append 1,"BBS/Log.DF"
  132.    Else 
  133.       Open Out 1,"BBS/Log.DF"
  134.    End If 
  135.    Print #1," "
  136.    Print #1,"--- Commune Answer Machine ---"
  137.    Print #1,"---      Session End       ---"
  138.    Print #1,DATE$,TIME$
  139.    Close 1
  140.    End 
  141.    '
  142. End Proc
  143. '
  144. ' Swap Serial Channels and Jump to Main BBS
  145. Procedure CON300
  146. Serial Open 1,0,True,False,False : Serial Speed 1,300 : Serial Bits 1,8,1
  147. Serial Parity 1,-1 : Serial Close 0 : BAUD$="300"
  148. Print "Connected at 300 Baud !" : BBS
  149. End Proc
  150. Procedure CON1200
  151. Serial Open 1,0,True,False,False : Serial Speed 1,1200 : Serial Bits 1,8,1
  152. Serial Parity 1,-1 : Serial Close 0 : BAUD$="1200"
  153. Print "Connected at 1200 Baud !" : 
  154. Serial Send 1,"Commune v0.01 - SysOp Answer Machine Release 1" : CHK[1]
  155. Serial Send 1,"(C) 1991 - Andrew Welsh" : CHK[1]
  156. BBS
  157. End Proc
  158. Procedure CON2400
  159.    Serial Open 1,0,True,False,False : Serial Speed 1,2400 : Serial Bits 1,8,1
  160.    Serial Parity 1,-1 : Serial Close 0 : BAUD$="2400"
  161.    Print "Connected at 2400 Baud !" : 
  162.    Serial Send 1,"Commune v0.01 - SysOp Answer Machine Release 1" : CHK[1]
  163.    Serial Send 1,"(C) 1991 - Andrew Welsh"+Chr$(13)+Chr$(13) : CHK[1]
  164.    BBS
  165. End Proc
  166. '
  167. ' Main Routine of BBS - From here you go to other Procs for Diff 
  168. ' Menus etc. 
  169. Procedure BBS
  170.    TMP$=Chr$(12)+Chr$(13)+Chr$(10) : Serial Send 1,TMP$ : CHK[1]
  171.    TMP$="You Have Connected at "+BAUD$ : Serial Send 1,TMP$ : CHK[1]
  172.    TMP$="Welcome to "+BNAME$+" ..." : Serial Send 1,TMP$ : CHK[1]
  173.    Rem We Will Now Break out into a SIMPLE ASCII Terminal.....
  174.    TITLE
  175.    _NAME_PW
  176.    _LOG_CALL
  177.    Serial Send 1,"HANG UP PLEASE !"+Chr$(13)
  178.    Serial Send 1,"+++"+Chr$(13)
  179.    Serial Send 1,"ath0"+Chr$(13)
  180.    '   Serial Send 1,"Simple Teminal - Sysop Is In !!" : CHK[1] 
  181.    '   TERMINAL:
  182.    '   Do 
  183.    '     A$=Inkey$ : S=Scancode 
  184.    '      Exit If S=89
  185.    '      IN$=Serial Input$(1)
  186.    '      If IN$<>"" Then Print IN$;
  187.    '      A$=Inkey$ : If A$<>"" Then Serial Send 1,A$ 
  188.    '      CHK[1]
  189.    '   Loop 
  190. End Proc
  191. '  
  192. ' CHK Checks to See If The Data is Finshed Being Sent
  193. ' The Paramater CH is The Serial CHANNEL Number....
  194. Procedure CHK[CH]
  195. L:
  196. CHK=Serial Check(CH) : If CHK=0 Then Goto L
  197. End Proc
  198. ' Get Time & Date from System
  199. Procedure _DATE$
  200.    '
  201.    ' Call DOS DateStamp function
  202.    T$=Space$(12)
  203.    Dreg(1)=Varptr(T$)
  204.    RIEN=Doscall(-192)
  205.    NJ=Leek(Varptr(T$))
  206.    '
  207.    ' Find this year's first day 
  208.    A=1978 : JOUR=7
  209.    Do 
  210.       BIS=0 : If(A and 3)=0 : BIS=1 : End If 
  211.       Exit If NJ-365-BIS<0
  212.       Add JOUR,1+BIS : If JOUR>7 : Add JOUR,-7 : End If 
  213.       Add NJ,-365-BIS
  214.       Inc A
  215.    Loop 
  216.    '
  217.    ' Find month 
  218.    M=1
  219.    Do 
  220.       Read N
  221.       Exit If NJ-N<0
  222.       Add NJ,-N : Inc M
  223.    Loop 
  224.    Inc NJ
  225.    '
  226.    ' Fabrique la chaine 
  227.    J$=Mid$(Str$(NJ),2) : If Len(J$)<2 : J$="0"+J$ : End If 
  228.    M$=Mid$(Str$(M),2) : If Len(M$)<2 : M$="0"+M$ : End If 
  229.    A$=Mid$(Str$(A),2)
  230.    DATE$=J$+"-"+M$+"-"+A$
  231.    '
  232.    ' Length of each month 
  233.    Data 31,28+BIS,31,30,31,30,31,31,30,31,30,31
  234.    '
  235.    '
  236.    ' Call DOS function
  237.    T$=Space$(12)
  238.    Dreg(1)=Varptr(T$)
  239.    RIEN=Doscall(-192)
  240.    MN=Leek(Varptr(T$)+4)
  241.    SEC=Leek(Varptr(T$)+8)
  242.    '
  243.    ' Minutes calculation
  244.    H=MN/60 : H$=Mid$(Str$(H),2) : If Len(H$)<2 : H$="0"+H$ : End If 
  245.    M=MN mod 60 : M$=Mid$(Str$(M),2) : If Len(M$)<2 : M$="0"+M$ : End If 
  246.    '
  247.    ' Seconds calculation  
  248.    S=SEC/50 : S$=Mid$(Str$(S),2) : If Len(S$)<2 : S$="0"+S$ : End If 
  249.    '
  250.    ' Final string 
  251.    TIME$=H$+":"+M$+":"+S$
  252.    '
  253.    Window 1
  254.    Home 
  255.    Locate 8,4
  256.    Print "                                                              "
  257.    Locate 8,4
  258.    Print "Chip Free";Chip Free,"Fast Free";Fast Free,DATE$,TIME$
  259. If WIN=0
  260.    Window 2
  261. Else 
  262.    Window 3
  263. End If 
  264.    Every On 
  265. End Proc
  266. Procedure TITLE
  267.    Open In 1,"BBS/Title"
  268.    Set Input 10,-1
  269.    Do 
  270.       Input #1,N$
  271.       '   Print N$ 
  272.       Serial Send 1,N$
  273.       CHK[1]
  274.       N=Eof(1)
  275.       Exit If N=-1
  276.    Loop 
  277.    Close 1
  278. End Proc
  279. ' Manual Modem Set-Up
  280. Procedure M0DEMST
  281. WIN=1
  282. Wind Open 3,0,182,79,9,2
  283. Title Top "Press F1 to Exit"
  284. Do 
  285.    A$=Inkey$ : S=Scancode
  286.    Exit If S=80
  287.    If A$<>""
  288.       Serial Send 0,A$
  289.       Wait Len(A$)
  290.    End If 
  291.    R=Serial Get(0)
  292.    If R=13 : Print : End If 
  293.    If R>31 : Print Chr$(R); : End If 
  294. Loop 
  295. Wind Close 
  296. WIN=0
  297. Window 2
  298. End Proc
  299. ' Useless Error Msg
  300. Procedure _WHAT
  301. Print "ERROR !! ERROR !!"
  302. Wait 100
  303. Resume Label 
  304. End Proc
  305. '
  306. Procedure _NAME_PW
  307.    Serial Send 1,Chr$(12)+"Enter Name : "
  308.    Do 
  309.       IN$=Serial Input$(1)
  310.       If IN$<>"" Then Print IN$;
  311.       If IN$="" Then Exit 
  312.       NAME$=NAME$+IN$
  313.    Loop 
  314. ' This Will search for user name and then password once I release
  315. ' a Full BBS Version !!
  316. End Proc
  317. Procedure _L0AD_CONFIG
  318.    '
  319.    Print "Loading Config File ..."
  320.    Open In 1,"BBS/Config.DF"
  321.    Set Input 10,-1
  322.    COUNT=0
  323.    Do 
  324.       Input #1,N$
  325.       If COUNT=0
  326.          SYSNAME$=N$
  327.       End If 
  328.       If COUNT=1
  329.          BNAME$=N$
  330.       End If 
  331.       If COUNT=2
  332.          HBAUD$=N$
  333.       End If 
  334.       N=Eof(1)
  335.       Exit If N=-1
  336.       Inc COUNT
  337.    Loop 
  338.    Close 1
  339. End Proc
  340. Procedure _LOG_CALL
  341.    If Exist("BBS/Log.DF")
  342.       Append 1,"BBS/Log.DF"
  343.    Else 
  344.       Open Out 1,"BBS/Log.DF"
  345.    End If 
  346. ' More to be Added 
  347.    Print #1,"---"
  348.    Print #1,NAME$+" at "+BAUD$
  349.    Print #1,DATE$
  350.    Close 1
  351. End Proc
  352. Procedure CHAT_TERMINAL
  353.    TMP$="SysOp Breaking In .." : Serial Send 1,TMP$ : CHK[1]
  354.    Do 
  355.       A$=Inkey$ : S=Scancode
  356.       Exit If S=80
  357.       IN$=Serial Input$(1)
  358.       If IN$<>"" Then Print IN$;
  359.       A$=Inkey$ : If A$<>"" Then Serial Send 1,A$
  360.       CHK[1]
  361.    Loop 
  362.    MAIN_MENU
  363. End Proc
  364. Procedure MAIN_MENU
  365.    MEN:
  366.    If FLAG$="1"
  367.       Open In 1,"BBS/Title"
  368.       Set Input 10,-1
  369.       Do 
  370.          Input #1,N$
  371.          Print N$
  372.          Serial Send 1,N$
  373.          CHK[1]
  374.          N=Eof(1)
  375.          Exit If N=-1
  376.       Loop 
  377.       Close 1
  378.    End If 
  379.    Do 
  380.       A$=Inkey$ : S=Scancode
  381.       If S=80 Then CHAT_TERMINAL
  382.       IN$=Serial Input$(1)
  383.       '      If IN$<>"" Then Print IN$;
  384.       'If IN$="g" Then BYE_BYE 
  385.       'If IN$="b" Then BULLS 
  386.       'If IN$="f" Then FILE_MENU 
  387.       If IN$="p" Then PAGE
  388.    Loop 
  389. End Proc
  390. Procedure PAGE
  391.    TMP$="Calling SysOp - Wait a Sec " : Serial Send 1,TMP$ : CHK[1]
  392.    Window 1
  393.    Home 
  394.    Print NAME$+" Paged Sysop ..."
  395.    Window 2
  396.    Flash 0,"(000,7)(FFF,1)"
  397.    Repeat 
  398.       Wait 10
  399.       Inc N
  400.    Until N=10
  401.    TMP$="SysOp is not around at the 'mo" : Serial Send 1,TMP$ : CHK[1]
  402.    MAIN_MENU
  403. End Proc
  404. '
  405. Procedure MOUSE_COLOURS_[A,B,C]
  406.    Colour 19,A
  407.    Colour 18,B
  408.    Colour 17,C
  409. End Proc
  410. '--------------- Colour changer routines --------------
  411. '
  412. Procedure CHANGERGB[X,Y,SCRN,C1,C2]
  413.    '  
  414.    ' Palette changer. 
  415.    '  
  416.    ' X,Y   - Coords of top left corner. (Will auto centre 
  417.    '         if coord is zero)
  418.    ' SCRN  - The screen to put requester on.  
  419.    ' C1,C2 - C1 - Body colour, C2 - The other colour. 
  420.    '
  421.    Shared X1,Y1,X2,Y2,YO,OK,CANCEL,DRAG,SP,LP
  422.    Dim RGB(31)
  423.    '
  424.    SC=Screen
  425.    Screen SCRN
  426.    Set Font 0 : Rem Select default font
  427.    Reserve Zone Screen Colour+10
  428.    ' ---  
  429.    W=204 : H=103 : NCOLS=Screen Colour
  430.    ' --- Centre requester if X or Y are zero
  431.    If X=0 Then X=Screen Width/2-W/2
  432.    If Y=0 Then Y=Screen Height/2-H/2
  433.    RGBINIT[X,Y,W,H,NCOLS]
  434.    Get Block 1,X1,Y1-YO,W+4,H+4+YO
  435.    ' --- Draw the requester --- 
  436.    Ink 0,0
  437.    Bar X1+3,Y1+3-YO To X1+W+3,Y1+H+3
  438.    Ink C1,C2
  439.    Bar X1,Y1-YO To X2,Y2
  440.    Ink C2,C1
  441.    Box X1+1,Y1+1-YO To X2-1,Y2-1
  442.    Ink C2,C1
  443.    ' --- slider bars
  444.    For A=0 To 2
  445.       Bar X1+7+A*20,Y1+3 To X1+23+A*20,Y2-3
  446.    Next 
  447.    ' --- Tic marks
  448.    For A=0 To 16
  449.       Draw X1+4,Y1+3+A*6 To X1+66,Y1+3+A*6
  450.    Next 
  451.    ' ---  palette 
  452.    For A=0 To Min(32,NCOLS)-1
  453.       Ink A,A : XX=A mod 8 : YY=A/8
  454.       Bar X1+XX*16+72,Y1+YY*16+4 To X1+XX*16+87,Y1+YY*16+20
  455.       RGB(A)=Colour(A)
  456.    Next 
  457.    Ink C2,C1
  458.    Box X1+71,Y1+3 To X1+88+16*XX,Y1+21+16*YY
  459.    ' --- OK CANCEL buttons
  460.    Box X1+72,Y1+87 To X1+132,Y1+97
  461.    Text X1+78,Y1+95,"Cancel"
  462.    '
  463.    Box X1+72,Y1+57 To X1+132,Y1+67
  464.    Text X1+78,Y1+65,"Load"
  465.    '
  466.    Box X1+144,Y1+87 To X1+194,Y1+97
  467.    Text X1+157,Y1+95,"O.K"
  468.    '
  469.    Box X1+144,Y1+57 To X1+194,Y1+67
  470.    Text X1+157,Y1+65,"Save"
  471.    '--- Selected colour 
  472.    SELCOL=0 : Rem default to colour 0
  473.    Ink SELCOL
  474.    Bar X1+187,Y1+75 To X1+193,Y1+84
  475.    Ink C2
  476.    Box X1+186,Y1+74 To X1+194,Y1+85
  477.    ' --- Drag bar 
  478.    Ink C2
  479.    Bar X1+4,Y1-YO+4 To X2-4,Y1
  480.    '------------------------------------------
  481.    ' --- draw RGB buttons 
  482.    SFADERS[SELCOL,X1,Y1,C1,C2]
  483.    ' --- main loop
  484.    CHANGING_COLOURS=True
  485.    While CHANGING_COLOURS
  486.       While Mouse Key=0
  487.       Wend 
  488.       YM=Y Screen(Y Mouse)-Y1+3 : Z=Mouse Zone
  489.       If Z>0 and Z<4
  490.          ' --- sliders moving 
  491.          CFADERS[SELCOL,Z-1,YM]
  492.          SFADERS[SELCOL,X1,Y1,C1,C2]
  493.       End If 
  494.       If Z>3 and Z<3+NCOLS+1
  495.          ' --- colour selected
  496.          SELCOL=Z-4
  497.          Ink SELCOL
  498.          Bar X1+187,Y1+75 To X1+193,Y1+84
  499.          SFADERS[SELCOL,X1,Y1,C1,C2]
  500.          Ink SELCOL
  501.       End If 
  502.       If Z=CANCEL
  503.          ' --- Cancel 
  504.          CHANGING_COLOURS=False
  505.          Clear Key 
  506.       End If 
  507.       If Z=LP
  508.          ' --- Load Palette 
  509.          PAL_LOAD[PALNAME$]
  510.       End If 
  511.       If Z=SP
  512.          ' --- Load Palette 
  513.          PAL_SAVE[PALNAME$]
  514.       End If 
  515.       If Z=OK
  516.          ' --- Ok 
  517.          A=0
  518.          Repeat 
  519.             Colour A,RGB(A) : SPCOL[A,RGB(A)]
  520.             Inc A
  521.          Until A>=Min(32,NCOLS)
  522.          CHANGING_COLOURS=False
  523.       End If 
  524.       If Z=DRAG
  525.          ' --- Drag bar 
  526.          WIDTH=W+4 : HEIGHT=H+3+YO
  527.          ' --- Get req image
  528.          Get Block 2,X1,Y1-YO,WIDTH,HEIGHT+1
  529.          MX=X Screen(X Mouse) : MY=Y Screen(Y Mouse)
  530.          MXO=MX-X1 : MYO=MY-Y1+YO
  531.          Gr Writing 2 : Rem XOR
  532.          Limit Mouse X Hard(MXO),Y Hard(MYO) To X Hard(Screen Width-(WIDTH-MXO)),Y Hard(Screen Height-(HEIGHT-MYO)-1)
  533.          While Mouse Key=1
  534.             Box MX-MXO,MY-MYO To MX-MXO+WIDTH,MY-MYO+HEIGHT
  535.             OLDX=MX : OLDY=MY
  536.             While OLDX=X Screen(X Mouse) and OLDY=Y Screen(Y Mouse) : Wend 
  537.             MX=X Screen(X Mouse) : MY=Y Screen(Y Mouse)
  538.             Box OLDX-MXO,OLDY-MYO To OLDX-MXO+WIDTH,OLDY-MYO+HEIGHT
  539.          Wend 
  540.          Limit Mouse X Hard(0),Y Hard(0) To X Hard(Screen Width),Y Hard(Screen Height)
  541.          Gr Writing 1
  542.          ' --- Restore bg at old location 
  543.          Put Block 1
  544.          ' --- Save bg at new location
  545.          Get Block 1,MX-MXO,MY-MYO,WIDTH,HEIGHT+1
  546.          ' --- Put Req at new location
  547.          Put Block 2,MX-MXO,MY-MYO
  548.          Del Block 2
  549.          ' --- Re-calc var's & zones ---
  550.          X=MX-MXO : Y=MY-MYO+YO
  551.          RGBINIT[X,Y,W,H,NCOLS]
  552.       End If 
  553.    Wend 
  554.    Put Block 1
  555.    Screen SC
  556.    Del Block 1
  557. End Proc
  558. '
  559. Procedure RGBINIT[X,Y,W,H,NCOLS]
  560.    ' Calc main vbls & set zones.
  561.    ' Has to be done twice, hence the proc.
  562.    Shared X1,Y1,X2,Y2,YO,OK,CANCEL,DRAG,SP,LP
  563.    X1=X : X2=X1+W : Y1=Y : Y2=Y1+H : YO=6
  564.    Z=1
  565.    For A=0 To 2
  566.       Set Zone Z,X1+7+A*20,Y1+3 To X1+23+A*20,Y2-3 : Inc Z
  567.    Next 
  568.    For A=0 To Min(32,NCOLS)-1
  569.       Ink A,A : XX=A mod 8 : YY=A/8
  570.       Set Zone Z,X1+XX*16+72,Y1+YY*16+4 To X1+XX*16+87,Y1+YY*16+20 : Inc Z
  571.    Next 
  572.    Set Zone Z,X1+72,Y1+87 To X1+132,Y1+97 : OK=Z : Inc Z
  573.    Set Zone Z,X1+72,Y1+57 To X1+132,Y1+67 : LP=Z : Inc Z
  574.    Set Zone Z,X1+146,Y1+87 To X1+194,Y1+97 : CANCEL=Z : Inc Z
  575.    Set Zone Z,X1+146,Y1+57 To X1+194,Y1+67 : SP=Z : Inc Z
  576. '  
  577. '  
  578.    Set Zone Z,X1+4,Y1-YO+4 To X2-4,Y1 : DRAG=Z
  579. End Proc
  580. '
  581. Procedure CFADERS[S,F,YM]
  582.    Dim R(2)
  583.    ' --- get RGB components of selected colour
  584.    C=Colour(S)
  585.    R(0)=C/256
  586.    R(1)=(C/16) mod 16
  587.    R(2)=C mod 16
  588.    ' --- amplitude of slider (0..15)
  589.    V=Max(0,Min(15,15-(YM-7)/6))
  590.    ' --- set RGB's value
  591.    R(F)=V
  592.    ' --- set selected colour
  593.    Colour S,(R(0)*256+R(1)*16+R(2))
  594.    ' ---  
  595.    SPCOL[S,Colour(S)]
  596. End Proc
  597. '
  598. Procedure SFADERS[S,X1,Y1,C1,C2]
  599.    Shared RGBO
  600.    Dim R(2)
  601.    '
  602.    C=RGBO
  603.    R(0)=C/256
  604.    R(1)=(C/16) mod 16
  605.    R(2)=C mod 16
  606.    ' --- Erase slider button
  607.    Ink C2,C2
  608.    For A=0 To 2
  609.       V=(15-R(A))*6+4
  610.       Bar X1+9+20*A,Y1+V To X1+20+20*A,Y1+V+5
  611.    Next 
  612.    ' --- set new colour value 
  613.    C=Colour(S)
  614.    RGBO=C
  615.    R(0)=C/256
  616.    R(1)=(C/16) mod 16
  617.    R(2)=C mod 16
  618.    ' --- print the colour value in hex
  619.    Ink C2,C1
  620.    Gr Writing 1
  621.    Text X1+72,Y1+82,"Col"+Right$(" "+Str$(S),2)+" Val:$"+Right$("000"+Mid$(Hex$(RGBO),2),3)
  622.    Ink C1,C1
  623.    ' --- draw new slider button 
  624.    For A=0 To 2
  625.       Ink C1,C1
  626.       V=(15-R(A))*6+4
  627.       Box X1+9+20*A,Y1+V To X1+20+20*A,Y1+V+5
  628.       Ink S
  629.       Bar X1+10+20*A,Y1+V+1 To X1+19+20*A,Y1+V+4
  630.    Next 
  631. End Proc
  632. '
  633. Procedure SPCOL[A,B]
  634.    If Length(1)>0
  635.       Doke Start(1)+2+8*Length(1)+2*A,B
  636.    End If 
  637. End Proc
  638. Procedure PAL_SAVE[PALNAME$]
  639.    TEMP=Screen
  640.    Screen SCR
  641.    Bsave PALNAME$,Screen Base+98 To Screen Base+162
  642. End Proc
  643. '
  644. Procedure PAL_LOAD[PALNAME$]
  645.    TEMP=Screen
  646.    Screen SCR
  647.    Bload PALNAME$,Screen Base+98
  648. Get Palette 0
  649.    Screen TEMP
  650. End Proc