home *** CD-ROM | disk | FTP | other *** search
/ AMOS PD CD / amospdcd.iso / 501-525 / apd515 / pic-pac.amos / pic-pac.amosSourceCode < prev    next >
AMOS Source Code  |  1992-02-23  |  11KB  |  344 lines
  1. Unpack 5 To 0
  2. Gr Writing 0
  3. Change Mouse 2
  4. Global SL,SY,SX,SH,SW,MY,BTS,OSH,OSW,OSY,OSX,CI,PL
  5. MY=235 : CI=0
  6. MAIN
  7. Procedure MAIN
  8.    Reserve Zone 73
  9.    Limit Mouse 0,0 To 640,400
  10.    Set Zone 1,121,7 To 155,17 : Rem LOAD 
  11.    Set Zone 2,121,19 To 155,29 : Rem SAVE 
  12.    Set Zone 3,159,7 To 193,17 : Rem PACK 
  13.    Set Zone 4,159,19 To 193,29 : Rem QUIT 
  14.    For X=1 To 10
  15.       Set Zone X+4,131+(X*20),64 To 147+(X*20),94
  16.    Next X
  17.    Set Zone 15,121,31 To 154,51 : Rem EDIT PALETTE 
  18.    Set Zone 16,9,111 To 67,121 : Rem RESTORE
  19.    Set Zone 17,70,111 To 104,121 : Rem PICK 
  20.    Set Zone 18,22,123 To 40,133 : Rem OK 
  21.    Set Zone 19,43,123 To 93,133 : Rem CANCEL 
  22.    Set Zone 20,115,95 To 137,110 : Rem UP ARROW 
  23.    Set Zone 21,115,114 To 137,129 : Rem DOWN ARROW 
  24.    For X=1 To 16
  25.       Set Zone X+21,194+(X*8),97 To 201+(X*8),103
  26.    Next X
  27.    For X=1 To 16
  28.       Set Zone X+37,194+(X*8),109 To 201+(X*8),115
  29.    Next X
  30.    For X=1 To 16
  31.       Set Zone X+53,194+(X*8),121 To 201+(X*8),127
  32.    Next X
  33.    Set Zone 70,49,199 To 163,222 : Rem RESTORE FULL 
  34.    Set Zone 71,171,199 To 304,222 : Rem RESTORE SELECTED 
  35.    Set Zone 72,63,228 To 158,251 : Rem PACK FULL
  36.    Set Zone 73,162,228 To 296,251 : Rem PACK PART
  37.    Y Mouse=260 : X Mouse=235
  38.    Do 
  39.       Repeat 
  40.          MZ=Mouse Zone : MC=Mouse Click
  41.          I$=Inkey$ : I$=Upper$(I$) : I=Scancode : OI$=Bin$(Key Shift,8)
  42.          If OI$="%00001000"
  43.             If I$="Y"
  44.                SY=OSY : Screen Display 1,,SY,,
  45.                Proc UDY
  46.             End If 
  47.             If I$="X"
  48.                SX=OSX : Screen Display 1,SX,,,
  49.                Proc UDX
  50.             End If 
  51.             If I$="W"
  52.                SW=OSW : Screen Display 1,,,SW,
  53.                Proc UDSW
  54.             End If 
  55.             If I$="H"
  56.                SH=OSH : Screen Display 1,,,,SH
  57.                Proc UDSH
  58.             End If 
  59.             If I$="A"
  60.                SX=OSX : SY=OSY : SW=OSW : SH=OSH
  61.                Screen Display 1,SX,SY,SW,SH
  62.                Proc UDX : Proc UDY : Proc UDSW : Proc UDSH
  63.             End If 
  64.          End If 
  65.          If OI$="%10000000"
  66.             If I=76
  67.                Dec MY : Screen Display 0,,MY,,
  68.             End If 
  69.             If I=77
  70.                Inc MY : Screen Display 0,,MY,,
  71.             End If 
  72.          End If 
  73.          If OI$="%00100000"
  74.             If I=76 and SL=1
  75.                Dec SH : Screen Display 1,,,,SH : Proc UDSH
  76.             End If 
  77.             If I=77 and SL=1
  78.                Inc SH : Screen Display 1,,,,SH : Proc UDSH
  79.             End If 
  80.             If I=79 and SL=1
  81.                Dec SW : Screen Display 1,,,SW, : Proc UDSW
  82.             End If 
  83.             If I=78 and SL=1
  84.                Inc SW : Screen Display 1,,,SW, : Proc UDSW
  85.             End If 
  86.          End If 
  87.          '------------------------------------------------
  88.          If OI$="%00000000"
  89.             If I=76 and SL=1
  90.                Dec SY : Screen Display 1,,SY,, : Proc UDY
  91.             End If 
  92.             If I=77 and SL=1
  93.                Inc SY : Screen Display 1,,SY,, : Proc UDY
  94.             End If 
  95.             If I=79 and SL=1
  96.                Dec SX : Screen Display 1,SX,,, : Proc UDX
  97.             End If 
  98.             If I=78 and SL=1
  99.                Inc SX : Screen Display 1,SX,,, : Proc UDX
  100.             End If 
  101.          End If 
  102.       Until MZ>0 and MC=1
  103.       On MZ Proc _LOAD,_SAVE,_PACK,_QUIT
  104.       If MZ=15 Then Proc _PALETTE
  105.    Loop 
  106. End Proc
  107. Procedure UDY
  108.    If SL=1
  109.       Screen 0 : Ink 8 : Bar 294,21 To 338,27
  110.       Ink 5 : Text 294,27,Str$(SY)-" "
  111.    End If 
  112. End Proc
  113. Procedure UDX
  114.    If SL=1
  115.       Screen 0 : Ink 8 : Bar 294,9 To 338,15
  116.       Ink 5 : Text 294,15,Str$(SX)-" "
  117.    End If 
  118. End Proc
  119. Procedure UDSH
  120.    If SL=1
  121.       Screen 0 : Ink 8 : Bar 214,21 To 250,27
  122.       Ink 5 : Text 214,27,Str$(SH)-" "
  123.    End If 
  124. End Proc
  125. Procedure UDSW
  126.    If SL=1
  127.       Screen 0 : Ink 8 : Bar 214,9 To 250,15
  128.       Ink 5 : Text 214,15,Str$(SW)-" "
  129.    End If 
  130. End Proc
  131. Procedure _LOAD
  132.    Ink 8 : Bar 256,33 To 338,50
  133.    F$=Fsel$("","","PICTURE COMPACTER by OSCARsoft","PICK AN IFF PICTURE")
  134.    If F$="" Then Pop Proc
  135.    Open In 1,F$ : L=Lof(1)
  136.    D$=Input$(1,20)
  137.    Close 1
  138.    BTS=0
  139.    If Instr(D$,"FORM")>0
  140.       Ink 3 : Text 260,39,Str$(L)-" "
  141.       Load Iff F$,1 : Screen Display 1,98,25,, : SX=98 : OSX=98 : SY=25 : OSY=25
  142.       SW=Screen Width(1) : OSW=SW : SH=Screen Height(1) : OSH=SH
  143.       Screen To Front 0 : Screen 0 : SL=1 : PL=0
  144.       Proc UDY : Proc UDX : Proc UDSW : Proc UDSH
  145.       Pop Proc
  146.    End If 
  147.    If Instr(D$,"Pac.Pic")>0
  148.       Load F$,4 : Unpack 4 To 1 : Erase 4
  149.       Screen 0 : Ink 3 : Text 260,39,Str$(L)-" "
  150.       Screen Display 1,98,25,, : SX=98 : OSX=98 : SY=25 : OSY=25
  151.       SW=Screen Width(1) : OSW=SW : SH=Screen Height(1) : OSH=SH
  152.       Screen Display 1,98,25,,SH
  153.       Screen To Front 0 : Screen 0 : SL=1 : PL=0
  154.       Proc UDY : Proc UDX : Proc UDSW : Proc UDSH
  155.       Pop Proc
  156.    End If 
  157.    If Instr(D$,"FORM")=0 or Instr(D$,"Pac.Pic")=0
  158.       Bell : Ink 6 : Text 275,39,"NOT AN"
  159.       Text 275,49,"IFF/ABK"
  160.       Wait 50
  161.       Ink 8 : Bar 256,33 To 338,50
  162.    End If 
  163. End Proc
  164. Procedure _SAVE
  165.    If SL=1 and BTS=0 Then Pop Proc
  166.    If SL=1 Then F$=Fsel$("","","PICTURE COMPACTER by OSCARsoft","SAVE PACKED FILE AS...")
  167.    If(SL=1) and(F$="") Then Pop Proc
  168.    If SL=1 and BTS>0 Then Save F$,BTS : Erase BTS
  169.    If SL=0
  170.       Bell : Ink 6 : Text 260,39,"NO PICTURE"
  171.       Text 275,49,"LOADED"
  172.       Wait 50
  173.       Ink 8 : Bar 256,33 To 338,50
  174.    End If 
  175. End Proc
  176. Procedure _PACK
  177.    If SL=1
  178.       Screen Offset 0,,224 : Screen Display 0,,,,29
  179.       Repeat 
  180.          MZ=Mouse Zone : MC=Mouse Click
  181.       Until MZ>71 and MC=1
  182.       If MZ=72
  183.          PM=1
  184.       Else 
  185.          PM=2
  186.       End If 
  187.       Screen Display 0,,,,27 : Screen Offset 0,0,61
  188.       Repeat 
  189.          MZ=Mouse Zone : MC=Mouse Click
  190.          If MC=2 : Goto G : End If 
  191.       Until MZ>4 and MC=1
  192.       Screen Offset 0,,148 : Screen Display 0,,,,25 : Wait 5
  193.       If PM=1
  194.          Spack 1 To MZ+1
  195.       End If 
  196.       If PM=2
  197.          Spack 1 To MZ+1,0,0,SW,SH
  198.       End If 
  199.       PM=0
  200.       BTS=MZ+1
  201.       PL=Length(MZ+1)
  202.       Ink 6 : Text 260,49,Str$(PL)-" "
  203.       Screen Display 0,,,,60 : Screen Offset 0,0,0
  204.    End If 
  205.    G:
  206.    If SL=1 and MC=2
  207.       Ink 8 : Bar 256,33 To 338,50
  208.       Screen Display 0,,,,60 : Screen Offset 0,0,0
  209.       Bell : Ink 6 : Text 270,39,"PACKING"
  210.       Text 268,49,"ABORTED!"
  211.       Wait 100
  212.       Ink 8 : Bar 256,33 To 338,50
  213.    End If 
  214.    If SL<>1
  215.       Bell : Ink 6 : Text 260,39,"NO PICTURE"
  216.       Text 275,49,"LOADED"
  217.       Wait 50
  218.       Ink 8 : Bar 256,33 To 338,50
  219.    End If 
  220. End Proc
  221. Procedure _QUIT
  222.    If SL=1 Then Screen Close 1
  223.    Screen 0 : Fade 3 : Wait 3*15
  224.    If PL>0 Then Erase BTS
  225.    End 
  226. End Proc
  227. Procedure _PALETTE
  228.    Screen 1 : If Screen Colour>64 Then Goto HAM
  229.    Dim R(1),G(1),B(1),CX(15)
  230.    For X=0 To 15 : CX(X)=205+(X*8) : Next X
  231.    If SL=0 Then Bell : Goto QUIT
  232.    NC=Screen Colour : Screen 0 : Dim PAL(NC)
  233.    Screen Offset 0,,89 : Screen Display 0,,,,47
  234.    Screen 1 : For X=0 To NC : PAL(X)=Colour(X) : Next X
  235.    Screen 0 : Ink 2 : Bar 141,97 To 172,103 : Ink 5 : NC$=Str$(NC)-" " : TL=Text Length(NC$) : TL=TL/2 : Text 158-TL,103,NC$
  236.    Ink 2 : Bar 141,121 To 172,127 : Ink 5 : NC$=Str$(CI)-" " : TL=Text Length(NC$) : TL=TL/2 : Text 158-TL,127,NC$
  237.    Gosub UDCI
  238.    M:
  239.    Repeat 
  240.       MZ=Mouse Zone : MC=Mouse Click
  241.    Until MZ>15 and MC=1
  242.    On MZ-15 Goto _RESTORE,PICK,QUIT,CANCEL
  243.    On MZ-19 Goto CIU,CID
  244.    If MZ>21 and MZ<38 Then Goto CR
  245.    If MZ>37 and MZ<54 Then Goto CG
  246.    If MZ>53 and MZ<70 Then Goto CB
  247.    Goto M
  248.    _RESTORE:
  249.    Screen Offset 0,,196 : Screen Display 0,,,,30
  250.    Repeat 
  251.       MZ=Mouse Zone : MC=Mouse Click
  252.    Until MZ>69 and MC=1
  253.    If MZ=70
  254.       If NC<33
  255.          Screen 1 : For X=0 To NC : Colour X,PAL(X) : Next X
  256.       End If 
  257.       If NC=64
  258.          Screen 1 : For X=0 To 31 : Colour X,PAL(X) : Next X
  259.       End If 
  260.    End If 
  261.    If MZ=71
  262.       Screen 1 : Colour CI,PAL(CI)
  263.    End If 
  264.    Screen Offset 0,,89 : Screen Display 0,,,,47
  265.    Screen 0 : Gosub UDCI
  266.    Goto M
  267.    PICK:
  268.    Screen Offset 0,,136 : Screen Display 0,,,,11 : Screen 1
  269.    Repeat 
  270.       CI=Point(X Screen(X Mouse),Y Screen(Y Mouse)) : Gosub UDCI
  271.       Screen 1 : MK=Mouse Click
  272.    Until MK=1 or MK=2
  273.    Screen Offset 0,,89 : Screen Display 0,,,,47
  274.    Screen 0
  275.    Goto M
  276.    CR:
  277.    If NC=64 and CI>31 Then Goto M
  278.    R(0)=R(1) : NRV=MZ-22 : Gosub SCV : R(1)=NRV
  279.    NRV$=Hex$(NRV)-" " : CI$=NRV$+GC$+BC$ : CI$=CI$-"$" : CI$="$"+CI$
  280.    Screen 1 : Colour CI,Val(CI$) : Screen 0 : Colour 15,Val(CI$)
  281.    Gosub UDR : Goto M
  282.    CG:
  283.    If NC=64 and CI>31 Then Goto M
  284.    G(0)=G(1) : NGV=MZ-38 : Gosub SCV : G(1)=NGV
  285.    NGV$=Hex$(NGV)-" " : CI$=RC$+NGV$+BC$ : CI$=CI$-"$" : CI$="$"+CI$
  286.    Screen 1 : Colour CI,Val(CI$) : Screen 0 : Colour 15,Val(CI$)
  287.    Gosub UDG : Goto M
  288.    CB:
  289.    If NC=64 and CI>31 Then Goto M
  290.    B(0)=B(1) : NBV=MZ-54 : Gosub SCV : B(1)=NBV
  291.    NBV$=Hex$(NBV)-" " : CI$=RC$+GC$+NBV$ : CI$=CI$-"$" : CI$="$"+CI$
  292.    Screen 1 : Colour CI,Val(CI$) : Screen 0 : Colour 15,Val(CI$)
  293.    Gosub UDB : Goto M
  294.    CIU:
  295.    If CI+1<NC-1 Then Inc CI : Gosub UDCI : Goto M
  296.    CI=0 : Gosub UDCI : Goto M
  297.    CID:
  298.    If CI-1>-1 Then Dec CI : Gosub UDCI : Goto M
  299.    CI=NC-1 : Gosub UDCI : Goto M
  300.    CANCEL:
  301.    If NC<33
  302.       Screen 1 : For X=0 To NC : Colour X,PAL(X) : Next X
  303.    End If 
  304.    If NC=64
  305.       Screen 1 : For X=0 To 31 : Colour X,PAL(X) : Next X
  306.    End If 
  307.    Screen 0 : Goto QUIT
  308.    UDR:
  309.    Ink 2 : Circle CX(R(0)),100,3 : Ink 6 : Circle CX(R(1)),100,3
  310.    Return 
  311.    UDG:
  312.    Ink 2 : Circle CX(G(0)),112,3 : Ink 3 : Circle CX(G(1)),112,3
  313.    Return 
  314.    UDB:
  315.    Ink 2 : Circle CX(B(0)),124,3 : Ink 7 : Circle CX(B(1)),124,3
  316.    Return 
  317.    SCV:
  318.    Screen 1 : CI$=Hex$(Colour(CI),3)-" "-"$" : Screen 0
  319.    RC$="$"+(Left$(CI$,1))-" " : GC$="$"+(Mid$(CI$,2,1))-" " : BC$="$"+(Right$(CI$,1))-" "
  320.    Return 
  321.    UDCI:
  322.    Screen 1 : MC=Colour(CI) : Screen 0 : Colour 15,MC
  323.    Gosub SCV
  324.    R(0)=R(1) : G(0)=G(1) : B(0)=B(1)
  325.    R(1)=Val(RC$) : G(1)=Val(GC$) : B(1)=Val(BC$)
  326.    Gosub UDR : Gosub UDG : Gosub UDB
  327.    Ink 2 : Bar 141,121 To 172,127 : Ink 5 : NC$=Str$(CI)-" " : TL=Text Length(NC$) : TL=TL/2 : Text 158-TL,127,NC$
  328.    Return 
  329.    HAM:
  330.    Screen Offset 0,,172 : Screen Display 0,,,,25 : Wait 100
  331.    Screen Display 0,,,,60 : Screen Offset 0,0,0 : Screen 0
  332.    Pop Proc
  333.    QUIT:
  334.    Screen Display 0,,,,60 : Screen Offset 0,0,0
  335.    Ink 2 : Circle CX(B(0)),124,3
  336.    Circle CX(G(0)),112,3
  337.    Circle CX(R(0)),100,3
  338.    If SL=0
  339.       Bell : Ink 6 : Text 260,39,"NO PICTURE"
  340.       Text 275,49,"LOADED"
  341.       Wait 50
  342.       Ink 8 : Bar 256,33 To 338,50
  343.    End If 
  344. End Proc