home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Format 67
/
af067a.adf
/
ACCESS.DMS
/
ACCESS.adf
/
IFF_Compactor.AMOS
/
IFF_Compactor.amosSourceCode
< prev
next >
Wrap
AMOS Source Code
|
1993-03-16
|
17KB
|
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
'