Amiga Format 67/af067a.adf/ACCESS.DMS/ACCESS.adf/IFF_Compactor.AMOS/IFF_Compactor.amosSourceCode

AMOS Source Code | 1993-03-16 | 16.5 KB | 575 lines

'---------------------------------------------------------------------------
' IFF Compactor
' By J.P. Cassier & F.Lionet
' (c) Europress Software 1992
'---------------------------------------------------------------------------
' This program will allow to grab the bank back to the previous program if
' it is called from the editor's menu, with a command line equal to "GRAB"
'---------------------------------------------------------------------------
'
Dim DIAL$(15)
Global Z,SX,SY,EX,EY,LEX,LEY,SCR0,TYPE$,DIAL$()
Global RES,NC,INF$,SCR,COM$,GRB

'  Stops the user leaving the program with Control-C
Break Off

' Grab the command line
If Command Line$="GRAB" : GRB=-1 : End If

' Call the INITIAL procedure to set up the menu
INITIAL

' If you want to automatically call the LOAD PICTURE option when the program
' is run, remove the ' in front of the PIC_LOAD statement below...
' PIC_LOAD
'
' - Main program loop
' - Reads the menu
Do
   ' Display a message on Screen 2 if required
   If INF$<>"" : INFO[INF$,0,0,0] : Screen 3 : End If
   ' Wait for the user to read the message
   TEST_KEY
   ' Read the menu zones
   Do
      ' Get the number of the menu option and load it into Z
      XM=X Screen(X Mouse) : YM=Y Screen(Y Mouse) : Z=Zone(XM,YM)
      ' If the user has pressed the Left mouse button, and the pointer
      ' is over a valid menu item, we'll call up the appropriate procedure
      If Mouse Key=1 and Z>0
         ' First, wait for the mouse button to be released
         TEST_MK
         ' Now execute the command
         If Z=1 : PIC_LOAD : Exit : End If : Rem LOAD PICTURE
         If Z=2 : SCR=1 : SELECT_ZONE : Exit : End If : Rem PACK AS SCREEN
         If Z=3 : SCR=0 : SELECT_ZONE : Exit : End If : Rem PACK AS BITMAP
         If Z=4 : SAVIT[1] : Exit : End If : Rem SAVE MEMORY BANK
         If Z=5 : SAVIT[0] : Exit : End If : Rem SAVE BINARY DATA
         If Z=6 : _QUIT : End If : Rem QUIT
      End If
      Multi Wait
   Loop
Loop
'
Procedure _QUIT

   If GRB
      If Prg Under
         If SCR0
            QUESTION["Copy bank (number 10) to previous program?","< Yes >","< No >",50]
            If Length(10)=0 : COMPACT : End If
            Bsend 10
         End If
      End If
   End If

   Erase 10 : Fade 1 : Wait 16
   For S=0 To 7 : Trap Screen Close S : Next
   Edit

End Proc
Procedure INITIAL
   ' - Initialises the screen and sets up all the variables
   '
   ' - Remove any existing pictures from memory
   Erase 10
   '
   ' - Enter the various system messages into DIAL$
   DIAL$(0)="Packing in progress."
   DIAL$(1)="Size of packed picture:"
   DIAL$(2)="Saving."
   DIAL$(3)="This is not an IFF file!"
   DIAL$(4)="Load a picture first !"
   DIAL$(5)="File not found !"
   DIAL$(6)="Bad IFF format !"
   DIAL$(7)="Loading: "
   DIAL$(8)="Current picture: "
   DIAL$(9)="Enter the name of the bank to save."
   DIAL$(10)="(bank number 10)"
   DIAL$(11)="Enter the name of the file to save."
   DIAL$(12)="(raw data)"
   DIAL$(13)="<SPACE> to pack, <ESC> to abort."
   DIAL$(14)="Please choose an IFF picture."
   DIAL$(15)="Press mouse-key."
   '
   ' - If we are currently looking at screen 0, fade it out
   If Screen=0
      Curs Off : Fade 1 : Wait 16
      ' and delete it!
      Screen Close 0
   End If
   '
   ' - Unpack the MENU picture from Bank 15, and load it into screen 3
   Unpack 15 To 3
   ' - Centre the menu screen on your TV display
   Screen Display 3,208,45,,
   ' - Reserve enough space for six menu items
   Reserve Zone 6
   ' - Now define the menu zones
   Set Zone 1,7,29 To 161,46 : Rem - LOAD IFF
   Set Zone 2,7,48 To 161,65 : Rem - PACK AS SCREEN
   Set Zone 3,7,67 To 161,84 : Rem - PACK AS BITMAP
   Set Zone 4,7,86 To 161,103 : Rem - SAVE MEMORY BANK
   Set Zone 5,7,105 To 161,122 : Rem - SAVE BINARY DATA
   Set Zone 6,7,124 To 161,141 : Rem - QUIT
   ' - Open a small screen for the INFO line
   Screen Open 2,640,8,2,Hires
   Screen Hide 2
   Curs Off
   Colour 1,$FFF
   '
   Screen 3
   Wait Vbl
   ' - Limit mouse to the title area of our menu
   Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
   '
   ' Choose PACK AS SCREEN as the default
   SCR=1
   '
End Proc
Procedure PIC_LOAD
   ' - Load an IFF picture
   '
   ' - Handle errors
   On Error Goto ERREUR
   '
   ' - Call up a file-selector
   F$=Fsel$("**","",DIAL$(14))
   ' If the user selects QUIT, EXIT from the procedure (EVITE means EXIT)
   If F$="" Then Goto EVITE
   '
   ' - If screen 0 is aleady open, we'll have to close it, so that
   ' - we can check whether the loading option was successful
   '
   ' - Display message line
   INFO[DIAL$(7)+Right$(F$,40),0,1,0]
   ' - Close screen 0
   If SCR0=1 Then Screen Close 0 : SCR0=0
   '
   ' - Load new picture into screen 0
   Load Iff F$,0
   ' - Hide the picture away in the background
   Screen To Back 0
   Screen Hide 0
   Wait Vbl
   '
   ' - Get the number of the current screen
   S=Screen
   ' - If S<>0, screen 0 has not been opened by the LOAD IFF command
   ' - So we know that the loading failed!
   ' - We've probably tried to load a file in the wrong format!
   ' - We'll therefore exit from the procedure with an error message
   ' - and let the user have another attempt
   If S<>0 Then Boom : INFO[DIAL$(3),0,1,1] : Goto EVITE
   '
   ' - If we've got this far, we know that the picture loaded successfully
   ' - So we'll grab the screen characteristics using a bit of AMOS magic
   ' - and continue...
    SCR0=1
   '
   RES=Screen Mode
   NC=Screen Colour
   ' - Set initial values for the bottom right corner of the selection window
   EX=Screen Width
   EY=Screen Height
   LEX=EX-1 : LEY=EY-1
   '
   ' - Open a work screen with the same number of colours as our picture
   Screen Open 1,EX,EY,NC,RES
   ' - Hide it away in the background for future use
   Screen To Back 1
   Screen Hide 1
   ' - Initialise it
   Curs Off : Flash Off
   ' - Load it with a copy of the picture, and grab the colour palette
   Screen Copy 0 To 1 : Get Palette 0
   Wait Vbl
   ' - Set start of the selection window used by PACK AS BITMAP
   SX=0 : SY=0
   EX=EX-1 : EY=EY-1
   ' - Display the full name of the current picture
   INF$=DIAL$(8)+Right$(F$,40)
   Hide On
   ' - Display picture on the screen
   Screen Show 0 : Screen To Front 0
   ' - Press mouse key message
   INFO[DIAL$(15),0,1,1]
   ' - Remove picture and hide it away in memory
   Screen Hide 0
   Show On
   '
   EVITE:
   Screen 3
   Pop Proc
   '
   ERREUR:
   ' - Handle errors
   ' - and display an appropriate message on the INFO line
   ERR=Errn
   ' - File not found
   If ERR=81
      INFO[DIAL$(5),0,1,1]
   End If
   ' - Bad IFF file
   If ERR=30
      INFO[DIAL$(6),0,1,1]
   End If
   INF$=""
   Change Mouse 1
   Resume EVITE
   '
End Proc
Procedure SELECT_ZONE
   ' - Selects a small part of the picture to be compressed
   ' - and then packs this screen using the COMPACT procedure
   '
   ' - If there's no picture, we'll return straight back to the menu
   If SCR0=0 Then INFO[DIAL$(4),0,1,1] : Screen 3 : Pop Proc
   '
   Screen 2 : Cls
   Screen Show 0
   Screen Hide 3
   Screen 0
   '
   ' - Create a dotted line for the grow box
   Set Line %1111000011110000
   '
   ' - Limit the mouse movements to the current screen area
   Limit Mouse X Hard(0),Y Hard(0) To X Hard(LEX),Y Hard(LEY)
   ' - Change mouse cursor to a set of crosshairs
   Change Mouse 2
   '
   ' - Draw grow box around the screen
   Box SX,SY To EX,EY
   '
   ' - Generate a grow box which can be controlled using the mouse
   Do
      ' - Get coordinates of the mouse, and check if a button has been pressed
      X=X Screen(X Mouse) : Y=Y Screen(Y Mouse) : K=Mouse Key
      K$=Inkey$
      ' - If the user has pressed a key
      If K$<>""
         ' - Wait for it to be released
         TEST_KEY
         '- If it's not ESC then COMPRESS the picture inside the grow box
         If Asc(K$)<>27
            COMPACT
         End If
         '
         ' - Reset mouse and remove screen 0
         Change Mouse 1
         Screen Hide 0
         '
         ' - If it's ESC then abort the operation and hide INFO line
         If Asc(K$)=27
            Screen Hide 2
         End If
         ' - Display menu again, and set the mouse movements back to normal
         Screen Show 3
         Screen 3
         Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
         '
         Pop Proc
         '
      End If
      ' - Display the INFO line along with the coords and size of the grow box
      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)+" "
      INFO[I$,Y,0,0] : Screen 0
      '
      ' - Now for the grow box stuff
      ' - LEFT button moves the top left corner of the box
      If K=1
         ' - Round the screen coordinate to the nearest eight pixels
         X=(X/8)*8
         ' - If the coordinates have changed, redraw the grow box
         If X<>SX and X<EX or Y<>SY and Y<EY
            ' - Redraw the screen under the old grow box
            Gosub EFFACE_R
            ' - If box is greater than 15 points wide
            If X<EX and EX-X>=15
               ' - Use the new coordinates
               SX=X
            Else
               ' - Expand the box to 15 points
               SX=EX-15
            End If
            ' - Check for minimum height
            If Y<EY and EY-Y>=7
               SY=Y
            Else
               SY=EY-7
            End If
            ' - Redraw box at new position
            Box SX,SY To EX,EY
            '
         End If
      End If
      '
      ' - RIGHT button moves the bottom right corner of the box
      If K=2
         X=7+(X/8)*8
         ' - If the coordinates have changed, redraw the grow box
         If X<>EX and X>SX or Y<>EY and Y>SY
            ' - Redraw the screen under the old grow box
            Gosub EFFACE_R
            ' - If box is greater than 15 points wide
            If X>SX and X-SX>=15
               ' - Use the new coordinates
               EX=X
            Else
               ' - Expand the box up to 15 points
               EX=SX+15
            End If
            ' - Check for minimum height
            If Y>SY and Y-SY>=7
               EY=Y
            Else
               EY=SY+7
            End If
            ' - Redraw box at new position
            Box SX,SY To EX,EY
            '
         End If
      End If
   Loop
   '
   EFFACE_R:
   ' - Replace the top line from the copy in screen 1
   Screen Copy 1,SX,SY,EX,SY+1 To 0,SX,SY
   ' - Bottom line
   Screen Copy 1,SX,EY,EX,EY+1 To 0,SX,EY
   ' - Left side
   Screen Copy 1,SX,SY,SX+1,EY+1 To 0,SX,SY
   ' - Right side
   Screen Copy 1,EX,SY,EX+1,EY+1 To 0,EX,SY
   Return
   '
End Proc
Procedure COMPACT
   ' - Compresses a screen or bitmap to a fraction of it's original size
   '
   ' - SCR selects the mode
   '      SCR  = 1 uses the PACK AS SCREEN option
   ' -         = 0 sets the PACK AS BITMAP system
   '
   ' - Display a message on the INFO line
   INFO[DIAL$(0),0,1,0]
   Change Mouse 3
   '
   ' - Select between PACK AS SCREEN and PACK AS BITMAP
   If SCR
      Gosub SCR : Rem PACK AS SCREEN
   Else
      Gosub ZON : Rem PACK AS BITMAP
   End If
   ' - Display length of compressed image
   INF$=DIAL$(1)+Str$(Length(10))
   ' - Redraw the menu, and return
   Screen 3
   Change Mouse 1
   '
   Pop Proc
   '
   ' - Pack as a screen
   SCR:
   ' - Restore the image to pristine condition using the copy in screen 1
   Screen Copy 1 To 0
   '
   L0=(LEX+1)/2 : Rem - L0=Screen width
   L1=(EX-SX)/16*16+16 : Rem - L1= Image width
   ' - Open a new screen with the exact dimensions of the image to be packed
   Screen Open 1,L1,1+EY-SY,NC,RES
   ' - Hide it away
   Screen Hide 1
   Screen Display 1,128+L0-(L1/2),,, : Rem - Centre screen number 1
   ' - Initialise it and load the original colours from screen 0
   Curs Off : Flash Off : Cls 0
   Get Palette 0
   Screen 0
   ' - Copy the selected area of the picture into the new screen
   Screen Copy 0,SX,SY,EX+1,EY+1 To 1,0,0
   ' - Pack it into memory bank 10
   Spack 1 To 10
   '
   ' - Open a new version of screen 1 to hold the full picture
   Screen Open 1,LEX+1,LEY+1,NC,RES
   Screen To Back 1 : Screen Hide 1
   Curs Off : Flash Off : Cls 0
   Get Palette 0
   ' - Copy the picture back into it from screen 0
   Screen Copy 0 To 1
   Return
   '
   ' - Pack as bitmap
   ZON:
   ' - Just pack the picture from screen 1
   ' - Easy isn't it!
   Pack 1 To 10,SX,SY,EX+1,EY+1
   Return
   '
End Proc
Procedure SAVIT[ABK]
   ' - Save the packed image into a new file on the disc
   '
   ' - ABK selects the mode
   '      ABK  = 1 uses the SAVE AS MEMORY BANK option
   ' -         = 0 sets the SAVE AS BINARY system
   '
   'Handle errors
   On Error Goto ERREUR
   '
   ' - If there's no picture, we'll return straight back to the menu
   If SCR0=0 Then INFO[DIAL$(4),0,1,1] : Screen 3 : Pop Proc
   '
   ' - Enter the name of a .ABK or .BIN file as appropriate
   If ABK
      S$=Fsel$("*.ABK","",DIAL$(9),DIAL$(10))
   Else
      S$=Fsel$("*.BIN","",DIAL$(11),DIAL$(12))
   End If
   '
   ' - If the filename is ok, then save it to the disc
   If S$<>""
      '
      ' - If the picture hasn't already been compressed, then pack it
      If Length(10)=0 : COMPACT : End If
      '
      ' - SAVE AS MEMORY BANK
      If ABK
         '
         INFO[DIAL$(2),0,1,0]
         Change Mouse 3
         Save S$,10
         '
      Else
         '
         ' - SAVE AS BINARY
         INFO[DIAL$(2),0,1,0]
         Change Mouse 3
         Bsave S$,Start(10) To Start(10)+Length(10)
         '
      End If
      '
      Change Mouse 1
   End If
   '
   EVITE:
   ' - Exit
   Screen 3
   Pop Proc
   '
   ERREUR:
   ' - handle errors
   Change Mouse 1
   Resume EVITE
   '
End Proc
Procedure TEST_MK
   '
   ' Tests mouse key
   '
   Y=27+Z+(Z-1)*18
   '
   Screen Copy 3,6,Y,162,Y+19 To 3,7,Y+1
   '
   ' Wait until a button has been released
   Repeat
      Multi Wait
   Until Mouse Key=0
   '
   'Animates the pressed button
   Screen Copy 3,7,Y+2,164,Y+20 To 3,6,Y+1
   '
   'Clears the area from where the button was copied from
   Cls 0,162,Y To 163,Y+20
   Cls 0,6,Y+19 To 162,Y+20
   '
End Proc
Procedure TEST_KEY
   ' - Wait until the mouse button has been released and the keyboard is free
   '
   Repeat
      Multi Wait
   Until Inkey$="" and Mouse Key=0
   '
End Proc
Procedure INFO[I$,Y,F,ALERT]
   ' - Displays an INFO line
   ' - I$    = Contains the message text to be displayed
   ' - Y     = Holds the Y position of the message screen
   ' - F     = CLS flag (Set it to one to clear the message line before use)
   ' - ALERT = FLASH flag (A value of one FLASHES the message on the screen)
   '
   ' - Display the line on screen 2
   Screen Show 2 : Screen To Front 2 : Screen 2
   '
   If F : Cls 0 : End If
   '
   'The message line is placed away from the mouse so that you can
   'ensure a clean grab is made
   If Y<140 Then Screen Display 2,128,238,,
   If Y>160 Then Screen Display 2,128,55,,
   '
   ' Display the appropriate text
   Centre I$
   '
   If ALERT
      ' Flash the message line on the screen
      Screen Show 2
      Flash 1,"(000,10)(fff,20)"
      '
      ' Wait for a keypress or a mouse click
      Repeat
      Until Inkey$<>"" or Mouse Key<>0
      '
      ' Wait for the keypress or mouse click to finish
      ' Stops the current command from accidentally selecting a menu option
      TEST_KEY
      '
      ' Turns off the flashing effect and removes the INFO line
      Flash Off
      Colour 1,$FFF : Cls 0
      Screen Hide 2
   End If
   '
End Proc
Procedure QUESTION[I$,Y$,N$,Y]

   Screen Show 2 : Screen To Front 2 : Screen 2
   Reserve Zone 2
   If Y<140 Then Screen Display 2,128,238,,
   If Y>160 Then Screen Display 2,128,55,,

   Palette 0,$FFF : Paper 0 : Pen 1
   Clw : Print I$; : Gosub PRT

   Wait Vbl
   Limit Mouse X Hard(0),Y Hard(0) To X Hard(Screen Width),Y Hard(Screen Height)

   Repeat
      Multi Wait
      Z=Mouse Zone : Gosub PRT
      A$=Upper$(Inkey$)
      If A$=Left$(Y$,1) : Z=1 : Exit : End If
      If A$=Left$(N$,1) : Z=2 : Exit : End If
   Until Z<>0 and Mouse Key<>0

   TEST_KEY

   Inverse Off : Cls 0
   Screen Hide 2
   Screen 3
   Wait Vbl
   Limit Mouse X Hard(5),Y Hard(26) To X Hard(163),Y Hard(143)
   Pop Proc

   PRT:
   If Z=1 : Inverse On Else Inverse Off : End If
   Locate 60,0 : Print Zone$(Y$,1);
   If Z=2 : Inverse On Else Inverse Off : End If
   Locate 70,0 : Print Zone$(N$,2);
   Return

End Proc
'