home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format 67 / af067a.adf / ACCESS.DMS / ACCESS.adf / IFF_Compactor.AMOS / IFF_Compactor.amosSourceCode < prev    next >
AMOS Source Code  |  1993-03-16  |  17KB  |  575 lines
  1. '---------------------------------------------------------------------------   
  2. ' IFF Compactor
  3. ' By J.P. Cassier & F.Lionet 
  4. ' (c) Europress Software 1992
  5. '--------------------------------------------------------------------------- 
  6. ' This program will allow to grab the bank back to the previous program if 
  7. ' it is called from the editor's menu, with a command line equal to "GRAB" 
  8. '--------------------------------------------------------------------------- 
  9. '
  10. Dim DIAL$(15)
  11. Global Z,SX,SY,EX,EY,LEX,LEY,SCR0,TYPE$,DIAL$()
  12. Global RES,NC,INF$,SCR,COM$,GRB
  13.  
  14. '  Stops the user leaving the program with Control-C 
  15. Break Off 
  16.  
  17. ' Grab the command line
  18. If Command Line$="GRAB" : GRB=-1 : End If 
  19.  
  20. ' Call the INITIAL procedure to set up the menu
  21. INITIAL
  22.  
  23. ' If you want to automatically call the LOAD PICTURE option when the program 
  24. ' is run, remove the ' in front of the PIC_LOAD statement below...   
  25. ' PIC_LOAD 
  26. '  
  27. ' - Main program loop
  28. ' - Reads the menu   
  29. Do 
  30.    ' Display a message on Screen 2 if required
  31.    If INF$<>"" : INFO[INF$,0,0,0] : Screen 3 : End If 
  32.    ' Wait for the user to read the message  
  33.    TEST_KEY
  34.    ' Read the menu zones  
  35.    Do 
  36.       ' Get the number of the menu option and load it into Z 
  37.       XM=X Screen(X Mouse) : YM=Y Screen(Y Mouse) : Z=Zone(XM,YM)
  38.       ' If the user has pressed the Left mouse button, and the pointer 
  39.       ' is over a valid menu item, we'll call up the appropriate procedure 
  40.       If Mouse Key=1 and Z>0
  41.          ' First, wait for the mouse button to be released  
  42.          TEST_MK
  43.          ' Now execute the command
  44.          If Z=1 : PIC_LOAD : Exit : End If : Rem LOAD PICTURE 
  45.          If Z=2 : SCR=1 : SELECT_ZONE : Exit : End If : Rem PACK AS SCREEN 
  46.          If Z=3 : SCR=0 : SELECT_ZONE : Exit : End If : Rem PACK AS BITMAP 
  47.          If Z=4 : SAVIT[1] : Exit : End If : Rem SAVE MEMORY BANK 
  48.          If Z=5 : SAVIT[0] : Exit : End If : Rem SAVE BINARY DATA 
  49.          If Z=6 : _QUIT : End If : Rem QUIT 
  50.       End If 
  51.       Multi Wait 
  52.    Loop 
  53. Loop 
  54. '
  55. Procedure _QUIT
  56.    
  57.    If GRB
  58.       If Prg Under
  59.          If SCR0
  60.             QUESTION["Copy bank (number 10) to previous program?","< Yes >","< No >",50]
  61.             If Length(10)=0 : COMPACT : End If 
  62.             Bsend 10
  63.          End If 
  64.       End If 
  65.    End If 
  66.    
  67.    Erase 10 : Fade 1 : Wait 16
  68.    For S=0 To 7 : Trap Screen Close S : Next 
  69.    Edit 
  70.    
  71. End Proc
  72. Procedure INITIAL
  73.    ' - Initialises the screen and sets up all the variables   
  74.    '
  75.    ' - Remove any existing pictures from memory 
  76.    Erase 10
  77.    '
  78.    ' - Enter the various system messages into DIAL$ 
  79.    DIAL$(0)="Packing in progress."
  80.    DIAL$(1)="Size of packed picture:"
  81.    DIAL$(2)="Saving."
  82.    DIAL$(3)="This is not an IFF file!"
  83.    DIAL$(4)="Load a picture first !"
  84.    DIAL$(5)="File not found !"
  85.    DIAL$(6)="Bad IFF format !"
  86.    DIAL$(7)="Loading: "
  87.    DIAL$(8)="Current picture: "
  88.    DIAL$(9)="Enter the name of the bank to save."
  89.    DIAL$(10)="(bank number 10)"
  90.    DIAL$(11)="Enter the name of the file to save."
  91.    DIAL$(12)="(raw data)"
  92.    DIAL$(13)="<SPACE> to pack, <ESC> to abort."
  93.    DIAL$(14)="Please choose an IFF picture."
  94.    DIAL$(15)="Press mouse-key."
  95.    '
  96.    ' - If we are currently looking at screen 0, fade it out   
  97.    If Screen=0
  98.       Curs Off : Fade 1 : Wait 16
  99.       ' and delete it! 
  100.       Screen Close 0
  101.    End If 
  102.    '
  103.    ' - Unpack the MENU picture from Bank 15, and load it into screen 3
  104.    Unpack 15 To 3
  105.    ' - Centre the menu screen on your TV display
  106.    Screen Display 3,208,45,,
  107.    ' - Reserve enough space for six menu items  
  108.    Reserve Zone 6
  109.    ' - Now define the menu zones
  110.    Set Zone 1,7,29 To 161,46 : Rem - LOAD IFF 
  111.    Set Zone 2,7,48 To 161,65 : Rem - PACK AS SCREEN   
  112.    Set Zone 3,7,67 To 161,84 : Rem - PACK AS BITMAP 
  113.    Set Zone 4,7,86 To 161,103 : Rem - SAVE MEMORY BANK 
  114.    Set Zone 5,7,105 To 161,122 : Rem - SAVE BINARY DATA 
  115.    Set Zone 6,7,124 To 161,141 : Rem - QUIT 
  116.    ' - Open a small screen for the INFO line
  117.    Screen Open 2,640,8,2,Hires
  118.    Screen Hide 2
  119.    Curs Off 
  120.    Colour 1,$FFF
  121.    '
  122.    Screen 3
  123.    Wait Vbl 
  124.    ' - Limit mouse to the title area of our menu  
  125.    Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
  126.    '
  127.    ' Choose PACK AS SCREEN as the default 
  128.    SCR=1
  129.    '
  130. End Proc
  131. Procedure PIC_LOAD
  132.    ' - Load an IFF picture
  133.    '
  134.    ' - Handle errors    
  135.    On Error Goto ERREUR
  136.    '
  137.    ' - Call up a file-selector
  138.    F$=Fsel$("**","",DIAL$(14))
  139.    ' If the user selects QUIT, EXIT from the procedure (EVITE means EXIT)   
  140.    If F$="" Then Goto EVITE
  141.    '
  142.    ' - If screen 0 is aleady open, we'll have to close it, so that  
  143.    ' - we can check whether the loading option was successful 
  144.    '
  145.    ' - Display message line 
  146.    INFO[DIAL$(7)+Right$(F$,40),0,1,0]
  147.    ' - Close screen 0 
  148.    If SCR0=1 Then Screen Close 0 : SCR0=0
  149.    '
  150.    ' - Load new picture into screen 0 
  151.    Load Iff F$,0
  152.    ' - Hide the picture away in the background
  153.    Screen To Back 0
  154.    Screen Hide 0
  155.    Wait Vbl 
  156.    '
  157.    ' - Get the number of the current screen 
  158.    S=Screen
  159.    ' - If S<>0, screen 0 has not been opened by the LOAD IFF command  
  160.    ' - So we know that the loading failed!
  161.    ' - We've probably tried to load a file in the wrong format! 
  162.    ' - We'll therefore exit from the procedure with an error message    
  163.    ' - and let the user have another attempt
  164.    If S<>0 Then Boom : INFO[DIAL$(3),0,1,1] : Goto EVITE
  165.    '
  166.    ' - If we've got this far, we know that the picture loaded successfully
  167.    ' - So we'll grab the screen characteristics using a bit of AMOS magic 
  168.    ' - and continue...  
  169.     SCR0=1
  170.    '
  171.    RES=Screen Mode
  172.    NC=Screen Colour
  173.    ' - Set initial values for the bottom right corner of the selection window 
  174.    EX=Screen Width
  175.    EY=Screen Height
  176.    LEX=EX-1 : LEY=EY-1
  177.    '
  178.    ' - Open a work screen with the same number of colours as our picture  
  179.    Screen Open 1,EX,EY,NC,RES
  180.    ' - Hide it away in the background for future use  
  181.    Screen To Back 1
  182.    Screen Hide 1
  183.    ' - Initialise it
  184.    Curs Off : Flash Off 
  185.    ' - Load it with a copy of the picture, and grab the colour palette
  186.    Screen Copy 0 To 1 : Get Palette 0
  187.    Wait Vbl 
  188.    ' - Set start of the selection window used by PACK AS BITMAP 
  189.    SX=0 : SY=0
  190.    EX=EX-1 : EY=EY-1
  191.    ' - Display the full name of the current picture   
  192.    INF$=DIAL$(8)+Right$(F$,40)
  193.    Hide On 
  194.    ' - Display picture on the screen  
  195.    Screen Show 0 : Screen To Front 0
  196.    ' - Press mouse key message  
  197.    INFO[DIAL$(15),0,1,1]
  198.    ' - Remove picture and hide it away in memory
  199.    Screen Hide 0
  200.    Show On 
  201.    '
  202.    EVITE:
  203.    Screen 3
  204.    Pop Proc
  205.    '
  206.    ERREUR:
  207.    ' - Handle errors
  208.    ' - and display an appropriate message on the INFO line
  209.    ERR=Errn
  210.    ' - File not found 
  211.    If ERR=81
  212.       INFO[DIAL$(5),0,1,1]
  213.    End If 
  214.    ' - Bad IFF file 
  215.    If ERR=30
  216.       INFO[DIAL$(6),0,1,1]
  217.    End If 
  218.    INF$=""
  219.    Change Mouse 1
  220.    Resume EVITE
  221.    '
  222. End Proc
  223. Procedure SELECT_ZONE
  224.    ' - Selects a small part of the picture to be compressed 
  225.    ' - and then packs this screen using the COMPACT procedure 
  226.    '
  227.    ' - If there's no picture, we'll return straight back to the menu
  228.    If SCR0=0 Then INFO[DIAL$(4),0,1,1] : Screen 3 : Pop Proc
  229.    '
  230.    Screen 2 : Cls 
  231.    Screen Show 0
  232.    Screen Hide 3
  233.    Screen 0
  234.    '
  235.    ' - Create a dotted line for the grow box
  236.    Set Line %1111000011110000
  237.    '
  238.    ' - Limit the mouse movements to the current screen area 
  239.    Limit Mouse X Hard(0),Y Hard(0) To X Hard(LEX),Y Hard(LEY)
  240.    ' - Change mouse cursor to a set of crosshairs 
  241.    Change Mouse 2
  242.    '  
  243.    ' - Draw grow box around the screen
  244.    Box SX,SY To EX,EY
  245.    '
  246.    ' - Generate a grow box which can be controlled using the mouse
  247.    Do 
  248.       ' - Get coordinates of the mouse, and check if a button has been pressed   
  249.       X=X Screen(X Mouse) : Y=Y Screen(Y Mouse) : K=Mouse Key
  250.       K$=Inkey$
  251.       ' - If the user has pressed a key
  252.       If K$<>""
  253.          ' - Wait for it to be released 
  254.          TEST_KEY
  255.          '- If it's not ESC then COMPRESS the picture inside the grow box 
  256.          If Asc(K$)<>27
  257.             COMPACT
  258.          End If 
  259.          '
  260.          ' - Reset mouse and remove screen 0
  261.          Change Mouse 1
  262.          Screen Hide 0
  263.          '
  264.          ' - If it's ESC then abort the operation and hide INFO line  
  265.          If Asc(K$)=27
  266.             Screen Hide 2
  267.          End If 
  268.          ' - Display menu again, and set the mouse movements back to normal 
  269.          Screen Show 3
  270.          Screen 3
  271.          Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
  272.          '
  273.          Pop Proc
  274.          '
  275.       End If 
  276.       ' - Display the INFO line along with the coords and size of the grow box 
  277.       I$=" Pointer: ("+Mid$(Str$(X),2)+","+Mid$(Str$(Y),2)+") - Box size: ("+Mid$(Str$(EX-SX+1),2)+","+Mid$(Str$(EY-SY+1),2)+")"+" - "+DIAL$(13)+" "
  278.       INFO[I$,Y,0,0] : Screen 0
  279.       '
  280.       ' - Now for the grow box stuff 
  281.       ' - LEFT button moves the top left corner of the box 
  282.       If K=1
  283.          ' - Round the screen coordinate to the nearest eight pixels
  284.          X=(X/8)*8
  285.          ' - If the coordinates have changed, redraw the grow box   
  286.          If X<>SX and X<EX or Y<>SY and Y<EY
  287.             ' - Redraw the screen under the old grow box 
  288.             Gosub EFFACE_R
  289.             ' - If box is greater than 15 points wide
  290.             If X<EX and EX-X>=15
  291.                ' - Use the new coordinates  
  292.                SX=X
  293.             Else 
  294.                ' - Expand the box to 15 points
  295.                SX=EX-15
  296.             End If 
  297.             ' - Check for minimum height 
  298.             If Y<EY and EY-Y>=7
  299.                SY=Y
  300.             Else 
  301.                SY=EY-7
  302.             End If 
  303.             ' - Redraw box at new position 
  304.             Box SX,SY To EX,EY
  305.             '
  306.          End If 
  307.       End If 
  308.       '
  309.       ' - RIGHT button moves the bottom right corner of the box  
  310.       If K=2
  311.          X=7+(X/8)*8
  312.          ' - If the coordinates have changed, redraw the grow box   
  313.          If X<>EX and X>SX or Y<>EY and Y>SY
  314.             ' - Redraw the screen under the old grow box 
  315.             Gosub EFFACE_R
  316.             ' - If box is greater than 15 points wide
  317.             If X>SX and X-SX>=15
  318.                ' - Use the new coordinates  
  319.                EX=X
  320.             Else 
  321.                ' - Expand the box up to 15 points 
  322.                EX=SX+15
  323.             End If 
  324.             ' - Check for minimum height 
  325.             If Y>SY and Y-SY>=7
  326.                EY=Y
  327.             Else 
  328.                EY=SY+7
  329.             End If 
  330.             ' - Redraw box at new position 
  331.             Box SX,SY To EX,EY
  332.             '
  333.          End If 
  334.       End If 
  335.    Loop 
  336.    '
  337.    EFFACE_R:
  338.    ' - Replace the top line from the copy in screen 1 
  339.    Screen Copy 1,SX,SY,EX,SY+1 To 0,SX,SY
  340.    ' - Bottom line
  341.    Screen Copy 1,SX,EY,EX,EY+1 To 0,SX,EY
  342.    ' - Left side  
  343.    Screen Copy 1,SX,SY,SX+1,EY+1 To 0,SX,SY
  344.    ' - Right side 
  345.    Screen Copy 1,EX,SY,EX+1,EY+1 To 0,EX,SY
  346.    Return 
  347.    '
  348. End Proc
  349. Procedure COMPACT
  350.    ' - Compresses a screen or bitmap to a fraction of it's original size
  351.    '
  352.    ' - SCR selects the mode 
  353.    '      SCR  = 1 uses the PACK AS SCREEN option   
  354.    ' -         = 0 sets the PACK AS BITMAP system 
  355.    '
  356.    ' - Display a message on the INFO line 
  357.    INFO[DIAL$(0),0,1,0]
  358.    Change Mouse 3
  359.    '
  360.    ' - Select between PACK AS SCREEN and PACK AS BITMAP 
  361.    If SCR
  362.       Gosub SCR : Rem PACK AS SCREEN 
  363.    Else 
  364.       Gosub ZON : Rem PACK AS BITMAP 
  365.    End If 
  366.    ' - Display length of compressed image 
  367.    INF$=DIAL$(1)+Str$(Length(10))
  368.    ' - Redraw the menu, and return  
  369.    Screen 3
  370.    Change Mouse 1
  371.    '
  372.    Pop Proc
  373.    '
  374.    ' - Pack as a screen 
  375.    SCR:
  376.    ' - Restore the image to pristine condition using the copy in screen 1 
  377.    Screen Copy 1 To 0
  378.    '
  379.    L0=(LEX+1)/2 : Rem - L0=Screen width
  380.    L1=(EX-SX)/16*16+16 : Rem - L1= Image width
  381.    ' - Open a new screen with the exact dimensions of the image to be packed
  382.    Screen Open 1,L1,1+EY-SY,NC,RES
  383.    ' - Hide it away 
  384.    Screen Hide 1
  385.    Screen Display 1,128+L0-(L1/2),,, : Rem - Centre screen number 1 
  386.    ' - Initialise it and load the original colours from screen 0
  387.    Curs Off : Flash Off : Cls 0
  388.    Get Palette 0
  389.    Screen 0
  390.    ' - Copy the selected area of the picture into the new screen
  391.    Screen Copy 0,SX,SY,EX+1,EY+1 To 1,0,0
  392.    ' - Pack it into memory bank 10
  393.    Spack 1 To 10
  394.    '
  395.    ' - Open a new version of screen 1 to hold the full picture  
  396.    Screen Open 1,LEX+1,LEY+1,NC,RES
  397.    Screen To Back 1 : Screen Hide 1
  398.    Curs Off : Flash Off : Cls 0
  399.    Get Palette 0
  400.    ' - Copy the picture back into it from screen 0
  401.    Screen Copy 0 To 1
  402.    Return 
  403.    '
  404.    ' - Pack as bitmap 
  405.    ZON:
  406.    ' - Just pack the picture from screen 1
  407.    ' - Easy isn't it! 
  408.    Pack 1 To 10,SX,SY,EX+1,EY+1
  409.    Return 
  410.    '
  411. End Proc
  412. Procedure SAVIT[ABK]
  413.    ' - Save the packed image into a new file on the disc  
  414.    '
  415.    ' - ABK selects the mode 
  416.    '      ABK  = 1 uses the SAVE AS MEMORY BANK option    
  417.    ' -         = 0 sets the SAVE AS BINARY system 
  418.    '
  419.    'Handle errors 
  420.    On Error Goto ERREUR
  421.    '
  422.    ' - If there's no picture, we'll return straight back to the menu
  423.    If SCR0=0 Then INFO[DIAL$(4),0,1,1] : Screen 3 : Pop Proc
  424.    '
  425.    ' - Enter the name of a .ABK or .BIN file as appropriate 
  426.    If ABK
  427.       S$=Fsel$("*.ABK","",DIAL$(9),DIAL$(10))
  428.    Else 
  429.       S$=Fsel$("*.BIN","",DIAL$(11),DIAL$(12))
  430.    End If 
  431.    '
  432.    ' - If the filename is ok, then save it to the disc    
  433.    If S$<>""
  434.       '
  435.       ' - If the picture hasn't already been compressed, then pack it  
  436.       If Length(10)=0 : COMPACT : End If 
  437.       '
  438.       ' - SAVE AS MEMORY BANK  
  439.       If ABK
  440.          '
  441.          INFO[DIAL$(2),0,1,0]
  442.          Change Mouse 3
  443.          Save S$,10
  444.          '
  445.       Else 
  446.          '
  447.          ' - SAVE AS BINARY 
  448.          INFO[DIAL$(2),0,1,0]
  449.          Change Mouse 3
  450.          Bsave S$,Start(10) To Start(10)+Length(10)
  451.          '
  452.       End If 
  453.       '
  454.       Change Mouse 1
  455.    End If 
  456.    '
  457.    EVITE:
  458.    ' - Exit 
  459.    Screen 3
  460.    Pop Proc
  461.    '
  462.    ERREUR:
  463.    ' - handle errors
  464.    Change Mouse 1
  465.    Resume EVITE
  466.    '
  467. End Proc
  468. Procedure TEST_MK
  469.    '
  470.    ' Tests mouse key
  471.    '
  472.    Y=27+Z+(Z-1)*18
  473.    '
  474.    Screen Copy 3,6,Y,162,Y+19 To 3,7,Y+1
  475.    '
  476.    ' Wait until a button has been released
  477.    Repeat 
  478.       Multi Wait 
  479.    Until Mouse Key=0
  480.    '
  481.    'Animates the pressed button 
  482.    Screen Copy 3,7,Y+2,164,Y+20 To 3,6,Y+1
  483.    '
  484.    'Clears the area from where the button was copied from 
  485.    Cls 0,162,Y To 163,Y+20
  486.    Cls 0,6,Y+19 To 162,Y+20
  487.    '
  488. End Proc
  489. Procedure TEST_KEY
  490.    ' - Wait until the mouse button has been released and the keyboard is free 
  491.    '
  492.    Repeat 
  493.       Multi Wait 
  494.    Until Inkey$="" and Mouse Key=0
  495.    '
  496. End Proc
  497. Procedure INFO[I$,Y,F,ALERT]
  498.    ' - Displays an INFO line  
  499.    ' - I$    = Contains the message text to be displayed  
  500.    ' - Y     = Holds the Y position of the message screen 
  501.    ' - F     = CLS flag (Set it to one to clear the message line before use)    
  502.    ' - ALERT = FLASH flag (A value of one FLASHES the message on the screen)  
  503.    '
  504.    ' - Display the line on screen 2 
  505.    Screen Show 2 : Screen To Front 2 : Screen 2
  506.    '
  507.    If F : Cls 0 : End If 
  508.    '
  509.    'The message line is placed away from the mouse so that you can  
  510.    'ensure a clean grab is made 
  511.    If Y<140 Then Screen Display 2,128,238,,
  512.    If Y>160 Then Screen Display 2,128,55,,
  513.    '
  514.    ' Display the appropriate text 
  515.    Centre I$
  516.    '
  517.    If ALERT
  518.       ' Flash the message line on the screen 
  519.       Screen Show 2
  520.       Flash 1,"(000,10)(fff,20)"
  521.       '
  522.       ' Wait for a keypress or a mouse click 
  523.       Repeat 
  524.       Until Inkey$<>"" or Mouse Key<>0
  525.       '
  526.       ' Wait for the keypress or mouse click to finish 
  527.       ' Stops the current command from accidentally selecting a menu option    
  528.       TEST_KEY
  529.       '
  530.       ' Turns off the flashing effect and removes the INFO line  
  531.       Flash Off 
  532.       Colour 1,$FFF : Cls 0
  533.       Screen Hide 2
  534.    End If 
  535.    '
  536. End Proc
  537. Procedure QUESTION[I$,Y$,N$,Y]
  538.    
  539.    Screen Show 2 : Screen To Front 2 : Screen 2
  540.    Reserve Zone 2
  541.    If Y<140 Then Screen Display 2,128,238,,
  542.    If Y>160 Then Screen Display 2,128,55,,
  543.  
  544.    Palette 0,$FFF : Paper 0 : Pen 1
  545.    Clw : Print I$; : Gosub PRT
  546.  
  547.    Wait Vbl 
  548.    Limit Mouse X Hard(0),Y Hard(0) To X Hard(Screen Width),Y Hard(Screen Height)
  549.  
  550.    Repeat 
  551.       Multi Wait 
  552.       Z=Mouse Zone : Gosub PRT
  553.       A$=Upper$(Inkey$)
  554.       If A$=Left$(Y$,1) : Z=1 : Exit : End If 
  555.       If A$=Left$(N$,1) : Z=2 : Exit : End If 
  556.    Until Z<>0 and Mouse Key<>0
  557.    
  558.    TEST_KEY
  559.    
  560.    Inverse Off : Cls 0
  561.    Screen Hide 2
  562.    Screen 3
  563.    Wait Vbl 
  564.    Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
  565.    Pop Proc
  566.    
  567.    PRT:
  568.    If Z=1 : Inverse On Else Inverse Off : End If 
  569.    Locate 60,0 : Print Zone$(Y$,1);
  570.    If Z=2 : Inverse On Else Inverse Off : End If 
  571.    Locate 70,0 : Print Zone$(N$,2);
  572.    Return 
  573.    
  574. End Proc
  575. '