Include	"Equ.s"
GetEc		equ $18
AdOrBank	equ $1C
EffBank		equ $20
	
******************************************************************
*	 **  *    * **** ****    ***    **  **** ***  ***
* 	*  * **  ** *  * *       *  *  *  * *     *  *
* 	**** * ** * *  * ****    ****  **** ****  *  *
* 	*  * *    * *  *    *    *   * *  *    *  *  *  
* 	*  * *    * **** ****    ****  *  * **** ***  ***
******************************************************************
*	
*	AMOS SCREEN COMPACTOR EXTENSION
*	
*	By Francois Lionet
*
*	AMOS (c) 1990 Mandarin / Jawx
*
******************************************************************
*	This source code is public domain. You can freely copy,
* modify, distribute it. Experiment with it, and have fun!
******************************************************************
*
*	ABOUT THIS PROGRAM
*
*	This extension obeys to the same rules than the music extension.
* Please refer to it for more information on AMOS interface.
*	It uses the same compaction process than STOS screen compactor,
* and have some nice features like automatic screen opening. For more
* informations on AMOS internal libraries functions, please join the
* AMOS club!
*
******************************************************************


******************************************************************
*	AMOS INTERFACE

*******	COLD START
	lea	PacAdr(pc),a1
	move.l	a0,(a1)			* Address of BRANCH TABLE
	moveq	#0,d2			* No check bank
	lea	Tk(pc),a0		* Address of TOKEN TABLE
	lea	PacWel(pc),a1		* Address of WELCOME MESSAGE
	lea	PacDef(pc),a2		* Address of SCREEN RESET
	lea	PacEnd(pc),a3		* Address of QUIT
	moveq	#1,d1			* Returns NUMBER OF EXTENSION
	moveq	#0,d0			* NO ERRORS
	rts

******* SCREEN RESET
PacDef:	rts

******* QUIT
PacEnd:	rts

******* Call normal error messages
Bkares	moveq	#35,d0
	bra.s	IError
OOMem	moveq	#24,d0			
	bra.s	IError
IFonc:	moveq	#23,d0			
IError:	move.l	PacAdr(pc),a0		
	jmp	4(a0)
******* Call customized error messages
Noscr	moveq	#1,d0
	bra.s	Custom
Nopac	moveq	#0,d0
Custom:	moveq	#0,d1			* Error can be trapped
	lea	PacErr(pc),a0		* Your list
	move.l	PacAdr(pc),a1
	jmp	8(a1)
******* Debugging
IBug:	move.l	PacAdr(pc),a0
	jmp	(a0)

*******************************************************************
*	PACK Screen,Bank#
*	PACK Screen,Bank#,X1,Y1 TO X2,Y2
Pack2	clr.l	-(a3)			* Y1
	clr.l	-(a3)			* X1
	move.l	#10000,-(a3)		* Y2
	move.l	(a3),-(a3)		* X2
Pack6	bsr	PacPar
	bsr	GetSize
	bsr	ResBank
	bsr	Pack
	rts
	
*******************************************************************
*	SPACK Screen,Bank#[,X1,Y1 TO X2,Y2]
SPack2	clr.l	-(a3)
	clr.l	-(a3)
	move.l	#10000,-(a3)
	move.l	(a3),-(a3)
SPack6	bsr	PacPar
	bsr	GetSize
	add.l	#PsLong,d0
	bsr	ResBank
* Screen definition header
	move.l	#SCCode,(a1)
	move.w	EcTx(a0),PsTx(a1)
	move.w	EcTy(a0),PsTy(a1)
	move.w	EcNbCol(a0),PsNbCol(a1)
	move.w	EcNPlan(a0),PsNPlan(a1)
	move.w	EcCon0(a0),PsCon0(a1)
	move.w	EcAWX(a0),PsAWX(a1)
	move.w	EcAWY(a0),PsAWY(a1)
	move.w	EcAWTX(a0),PsAWTX(a1)
	move.w	EcAWTY(a0),PsAWTY(a1)
	move.w	EcAVX(a0),PsAVX(a1)
	move.w	EcAVY(a0),PsAVY(a1)
	movem.l	a0/a1,-(sp)
	moveq	#31,d0
	lea	EcPal(a0),a0
	lea	PsPal(a1),a1
SPac1	move.w	(a0)+,(a1)+
	dbra	d0,SPac1
	movem.l	(sp)+,a0/a1
	lea	PsLong(a1),a1
* Finish packing!
	bsr	Pack
	rts

******* Reserves memory bank
ResBank	movem.l	a0/d1,-(sp)
	addq.l	#8,d0
	move.l	d0,d1
	SyCall	SyFast
	beq	OOMem
	move.l	d0,(a1)+
	bset	#31,d1
	move.l	d1,(a1)+
	move.l	d0,a1
	lea	BkPac(pc),a0
	move.l	(a0)+,(a1)+
	move.l	(a0)+,(a1)+
	movem.l	(sp)+,a0/d1
	rts

******* Unpile parameters
*	Screen-> a0/a2
*	Bank  -> a1
PacPar	move.l	(a3)+,d5
	move.l	(a3)+,d4
	move.l	(a3)+,d3
	move.l	(a3)+,d2
	lsr.w	#3,d4
	lsr.w	#3,d2
* Screen
	move.l	4(a3),d1
	move.l	PacAdr(pc),a0
	jsr	GetEc(a0)
	move.l	d0,a2
	cmp.w	EcTLigne(a0),d4
	bls.s	PacP1
	move.w	EcTLigne(a0),d4
PacP1	cmp.w	EcTy(a0),d5
	bls.s	PacP2
	move.w	EcTy(a0),d5
PacP2	sub.w	d2,d4
	ble	IFonc
	sub.w	d3,d5
	ble	IFonc
* Memory bank
	move.l	d3,-(sp)
	move.l	(a3)+,d3
	subq.l	#1,d3
	cmp.l	#16,d3
	bcc	IFonc
	move.l	PacAdr(pc),a1		* Erase bank
	jsr	EffBank(a1)
	lsl.w	#3,d3			* Address of pointer
	move.l	ABanks(a5),a1
	add.w	d3,a1
	tst.l	(a1)
	bne	IFonc
	move.l	(sp)+,d3
	addq.l	#4,a3
	rts
	
***************************************************************************
* 
*       BITMAP COMPACTOR
*                       A0: Origin screen datas
*                       A1: Destination zone
*			A2: Origin screen bitmap
*                       D2: DX in BYTES
*                       D3: DY in LINES
*                       D4: TX in BYTES
*                       D5: TY in LINES
*
***************************************************************************

***************************************************************************
* 	ESTIMATE THE SIZE OF A PICTURE

******* Makes differents tries
*	And finds the best square size in D1
GetSize	movem.l	a1-a3,-(sp)
	lea	TSize(pc),a3
	move.l	Buffer(a5),a1
	moveq	#0,d7
	move.w	d5,d7
	clr.w	-(sp)
	move.l	#$10000000,-(sp)
GSize1	move.l	d7,d5
	move.w	(a3)+,d1
	beq.s	GSize2
	divu	d1,d5
	swap	d5
	tst.w	d5
	bne.s	GSize1
	swap	d5
	bsr	PacSize
	cmp.l	(sp),d0
	bcc.s	GSize1
	move.l	d0,(sp)
	move.w	d1,4(sp)
	bra.s	GSize1
GSize2	move.l	(sp)+,d0
	move.w	(sp)+,d1
	move.l	d7,d5
	divu	d1,d5
	movem.l	(sp)+,a1-a3
	rts

******* Simulate a packing
PacSize	movem.l	d1-d7/a0-a6,-(sp)
* Fake data zone
        move.w 	d2,Pkdx(a1)
        move.w 	d3,Pkdy(a1)  
        move.w 	d4,Pktx(a1)  
        move.w 	d5,Pkty(a1)   
        move.w 	d1,Pktcar(a1)  
* Reserve intermediate table space
	move.w	d1,d0
	mulu	d4,d0
	mulu	d5,d0
	mulu	EcNPlan(a0),d0
	lsr.l	#3,d0
	addq.l	#2,d0
	move.l	d0,-(sp)
	move.l	a0,-(sp)
	SyCall	SyFast
	beq	OoMem
	move.l	(sp)+,a0
	move.l	d0,a6
	move.l	d0,-(sp)
* Prepare registers
        move.l	a2,a4	        	;a4--> picture address
        lea 	PkDatas1(a1),a5        	;a5--> main datas
	move.w	EcTLigne(a0),d7
	move.w	d7,d5
	mulu	d1,d5			;d5--> SY line of square
        move.w 	Pkdy(a1),d3
        mulu 	d7,d3
        move.w 	Pkdx(a1),d0
	ext.l	d0
	add.l	d0,d3
	move.w	EcNPlan(a0),-(sp)
* Main packing
        moveq 	#7,d1  		        * Bit pointer
	moveq	#0,d0
Iplan:  move.l 	(a4)+,a3
	add.l	d3,a3
        move.w 	Pkty(a1),d6
	subq.w	#1,d6
Iligne: move.l 	a3,a2
	move.w	Pktx(a1),d4
	subq.w	#1,d4
Icarre: move.l 	a2,a0
        move.w 	Pktcar(a1),d2
	subq.w	#1,d2
Ioct0: 	cmp.b 	(a0),d0         	* Compactage d'un carre
        beq.s 	Ioct1
	move.b	(a0),d0
        addq.l 	#1,a5
        bset 	d1,(a6)
Ioct1:  dbra 	d1,Ioct2
        moveq 	#7,d1
        addq.l 	#1,a6
	clr.b	(a6)
Ioct2:  add.w 	d7,a0
        dbra 	d2,Ioct0
        addq.l	#1,a2	
        dbra 	d4,Icarre	
	add.l	d5,a3	
        dbra 	d6,Iligne	
	subq.w	#1,(sp)
	bne.s	IPlan
	addq.l	#2,sp
	addq.l	#1,a5
* Packing of first pointers table
	move.l	a5,a6
	move.l	4(sp),d2
	move.l	d2,d0
	subq.w	#1,d2
	lsr.w	#3,d0
	addq.w	#2,d0
	add.w	d0,a5
	move.l	(sp),a0
	moveq	#0,d0
        moveq 	#7,d1
Icomp2  cmp.b 	(a0)+,d0
        beq.s 	Icomp2a
	move.b	-1(a0),d0
        addq.l 	#1,a5
Icomp2a dbra	d2,Icomp2
* Final size (EVEN!)
	move.l	a5,d2
	sub.l	a1,d2
	addq.l	#3,d2
	and.l	#$FFFFFFFE,d2
* Free intermediate memory
	move.l	(sp)+,a1
	move.l	(sp)+,d0
	SyCall	SyFree
* Finished!
	move.l	d2,d0
	movem.l	(sp)+,d1-d7/a0-a6
	rts

***********************************************************
*	REAL PACKING!!!
Pack:

* Header of the packed bitmap
	movem.l	d1-d7/a0-a6,-(sp)

* Packed bitmap header
        move.l 	#BMCode,PkCode(a1)
        move.w 	d2,Pkdx(a1)
        move.w 	d3,Pkdy(a1)  
        move.w 	d4,Pktx(a1)  
        move.w 	d5,Pkty(a1)   
        move.w 	d1,Pktcar(a1)  
	move.w	EcNPlan(a0),PkNPlan(a1)

* Reserve intermediate table space
	move.w	d1,d0
	mulu	d4,d0
	mulu	d5,d0
	mulu	EcNPlan(a0),d0
	lsr.l	#3,d0
	addq.l	#2,d0
	move.l	d0,-(sp)
	move.l	a0,-(sp)
	SyCall	SyFast
	beq	OoMem
	move.l	(sp)+,a0
	move.l	d0,a6
	move.l	d0,-(sp)

* Prepare registers
        move.l	a2,a4        		;a4--> picture address
        lea 	PkDatas1(a1),a5        	;a5--> main datas
	move.w	EcTLigne(a0),d7
	move.w	d7,d5
	mulu	d1,d5			;d5--> SY line of square
        move.w 	Pkdy(a1),d3
        mulu 	d7,d3
        move.w 	Pkdx(a1),d0
	lsr.w	#3,d0
	ext.l	d0
	add.l	d0,d3
	move.w	EcNPlan(a0),-(sp)

* Main packing
        moveq 	#7,d1  		        * Bit pointer
	moveq	#0,d0
        clr.b 	(a5)              	* First byte to zero
        clr.b 	(a6)              
plan:   move.l 	(a4)+,a3
	add.l	d3,a3
        move.w 	Pkty(a1),d6
	subq.w	#1,d6
ligne:  move.l 	a3,a2
	move.w	Pktx(a1),d4
	subq.w	#1,d4
carre:  move.l 	a2,a0
        move.w 	Pktcar(a1),d2
	subq.w	#1,d2
oct0: 	cmp.b 	(a0),d0         	* Compactage d'un carre
        beq.s 	oct1
	move.b	(a0),d0
        addq.l 	#1,a5
        move.b 	d0,(a5)
        bset 	d1,(a6)
oct1:   dbra 	d1,oct2
        moveq 	#7,d1
        addq.l 	#1,a6
        clr.b 	(a6)
oct2:   add.w 	d7,a0
        dbra 	d2,oct0
        addq.l	#1,a2			* Carre suivant en X
        dbra 	d4,carre	
	add.l	d5,a3			* Ligne suivante
        dbra 	d6,ligne	
	subq.w	#1,(sp)			* Plan couleur suivant
	bne.s	Plan
	addq.l	#2,sp
	addq.l	#1,a5

; Packing of first pointers table
	move.l	a5,d0
	sub.l	a1,d0
	move.l	d0,PkPoint2(a1)
	move.l	a5,a6
	move.l	4(sp),d0
	move.l	d0,d2
	subq.w	#1,d2
	lsr.w	#3,d0
	addq.w	#2,d0
	add.w	d0,a5
	move.l	a5,d0
	sub.l	a1,d0
	move.l	d0,PkDatas2(a1)
	move.l	(sp),a0
	moveq	#0,d0
        moveq 	#7,d1
        clr.b 	(a5)
        clr.b 	(a6)
comp2:  cmp.b 	(a0)+,d0
        beq.s 	comp2a
	move.b	-1(a0),d0
        addq.l 	#1,a5
        move.b 	d0,(a5)
        bset 	d1,(a6)
comp2a: dbra 	d1,comp2b
        moveq 	#7,d1
        addq.l 	#1,a6
        clr.b 	(a6)
comp2b: dbra	d2,Comp2

* Free intermediate memory
	move.l	(sp)+,a1
	move.l	(sp)+,d0
	SyCall	SyFree
	movem.l	(sp)+,d1-d7/a0-a6
	rts

*************************************************************************
*	UNPACK Bank# 		-> To current screen
*	UNPACK Bank#,X,Y	-> To current screen
UPack1	move.l	ScOnAd(a5),d0
	beq	IFonc
	move.l	d0,a1
	moveq	#-1,d1
	moveq	#-1,d2
	bra.s	UPack
UPack3	move.l	ScOnAd(a5),d0
	beq	IFonc
	move.l	d0,a1
	move.l	(a3)+,d2
	move.l	(a3)+,d1
	lsr.l	#3,d1
UPack	movem.l	d1/d2/a1/a2,-(sp)
	move.l	PacAdr(pc),a0
	jsr	AdOrBank(a0)
	movem.l	(sp)+,d1/d2/a1/a2
	move.l	d3,a0
* Autoback 
	tst.w	EcAuto(a1)		* Is screen autobacked?
	beq	UnPack			* NOPE! Do simple unpack
	movem.l	d0-d7/a0-a2,-(sp)	* YEP! First step
	EcCall	AutoBack1
	movem.l	(sp),d0-d7/a0-a2
	btst	#BitDble,EcFlags(a1)	* DOUBLE BUFFER?
	beq.s	ABPac1
	bsr	UnPack
	EcCall	AutoBack2		* Second step
	movem.l	(sp),d0-d7/a0-a2
	bsr	UnPack
	EcCall	AutoBack3		* Third step
	bra.s	ABPac2
ABPac1	bsr	UnPack			* SINGLE BUFFER autobacked
	EcCall	AutoBack4
ABPac2	movem.l	(sp)+,d0-d7/a0-a2
	rts

*************************************************************************
*	UNPACK Bank# TO screen	-> Creates/Erases screen!
UPack2	move.l	(a3)+,d1
	cmp.l	#8,d1
	bcc	IFonc
* Creates new screen
	move.l	d1,-(sp)
	move.l	PacAdr(pc),a0
	jsr	AdOrBank(a0)
	move.l	(sp)+,d1
	move.l	d3,a0
	cmp.l	#SCCode,PsCode(a0)
	bne	NoScr
	moveq	#0,d2
	moveq	#0,d3
	moveq	#0,d4
	moveq	#0,d5
	move.w	PsTx(a0),d2
	move.w	PsTy(a0),d3
	move.w	PsNPlan(a0),d4
	move.w	PsCon0(a0),d5
	move.w	PsNbCol(a0),d6
	lea	PsPal(a0),a1
	move.l	a0,-(sp)
	EcCall	Cree
	bne	OOMem
	move.l	a0,a1
	move.l	(sp)+,a0
	move.l	a1,ScOnAd(a5)
	move.w	EcNumber(a1),ScOn(a5)
	addq.w	#1,ScOn(a5)
* Change View/Offset
	move.w	PsAWX(a0),EcAWX(a1)
	move.w	PsAWY(a0),EcAWY(a1)
	move.w	PsAWTx(a0),EcAWTx(a1)
	move.w	PsAWTy(a0),EcAWTy(a1)
	move.w	PsAVX(a0),EcAVX(a1)
	move.w	PsAVY(a0),EcAVY(a1)
	move.b	#%110,EcAW(a1)
	move.b	#%110,EcAWT(a1)
	move.b	#%110,EcAV(a1)
* Unpack!
	lea	PsLong(a0),a0
	moveq	#0,d1
	moveq	#0,d2
	bsr	UnPack
	rts

******* Bitmap unpacker
*	A0-> packed picture
*	A1-> Destination screen
*	D1.L Start in X
*	D2.L Start in Y
UAEc:	equ 0
UDEc:	equ 4
UITy:	equ 8
UTy:	equ 10
UTLine:	equ 12
UNPlan:	equ 14
UPile:	equ 16
UnPack:	movem.l	a0-a6/d1-d7,-(sp)

* Jump over SCREEN DEFINITION
	cmp.l	#SCCode,(a0)
	bne.s	dec0
	lea	PsLong(a0),a0
* Is it a packed bitmap?
dec0	cmp.l	#BMCode,(a0)
	bne	NoPac

* Parameter preparation
	lea	-UPile(sp),sp		* Space to work
	lea	EcCurrent(a1),a2
	move.l	a2,UAEc(sp)		* Bitmaps address
        move.w 	EcTLigne(a1),d7    	* d7--> line size
	move.w	EcNPlan(a1),d0		* How many bitplanes
	cmp.w	PkNPlan(a0),d0
	bne	IFonc
	move.w	d0,UNPlan(sp)
	move.w	Pktcar(a0),d6		* d6--> SY square

        tst.l 	d1			* Screen address in X
        bpl.s 	dec1
        move.w 	Pkdx(a0),d1
dec1:   tst.l 	d2			* In Y
        bpl.s 	dec2
        move.w 	Pkdy(a0),d2
dec2:   move.w	Pktx(a0),d0
	add.w	d1,d0
	cmp.w	d7,d0
	bhi	IFonc
	move.w	Pkty(a0),d0
	mulu	d6,d0
	add.w	d2,d0
	cmp.w	EcTy(a1),d0
	bhi	IFonc

	mulu	d7,d2			* Screen address
	ext.l	d1	
	add.l	d2,d1
	move.l	d1,UDEc(sp)
	
	move.w	d6,d0			* Size of one line
        mulu 	d7,d0
        move 	d0,UTLine(sp)

        move.w 	Pktx(a0),a3		* Size in X
        subq.w	#1,a3
        move.w 	Pkty(a0),UITy(sp)	* in Y
        lea 	PkDatas1(a0),a4        	* a4--> bytes table 1
        move.l 	a0,a5
        move.l 	a0,a6
        add.l 	PkDatas2(a0),a5     	* a5--> bytes table 2
        add.l 	PkPoint2(a0),a6     	* a6--> pointer table

        moveq 	#7,d0			
        moveq 	#7,d1
        move.b 	(a5)+,d2
        move.b 	(a4)+,d3
        btst 	d1,(a6)
        beq.s 	prep
        move.b 	(a5)+,d2
prep:   subq.w 	#1,d1

* Unpack!
dplan:  move.l 	UAEc(sp),a2
	addq.l	#4,UAEc(sp)
	move.l	(a2),a2
	add.l	UDEc(sp),a2
        move.w 	UITy(sp),UTy(sp)	* Y Heigth counter
dligne: move.l 	a2,a1
        move.w 	a3,d4
dcarre: move.l 	a1,a0
        move.w 	d6,d5   		* Square height
doctet1:subq.w 	#1,d5
        bmi.s 	doct3
        btst 	d0,d2
        beq.s 	doct1
        move.b 	(a4)+,d3
doct1:  move.b 	d3,(a0)
        add.w 	d7,a0
        dbra 	d0,doctet1
        moveq 	#7,d0
        btst 	d1,(a6)
        beq.s 	doct2
        move.b 	(a5)+,d2
doct2:  dbra 	d1,doctet1
        moveq 	#7,d1
        addq.l 	#1,a6
        bra.s 	doctet1
doct3:  addq.l	#1,a1           	* Other squares?
        dbra 	d4,Dcarre
        add.w 	UTLine(sp),a2          	* Other square line?
        subq.w 	#1,UTy(sp)
        bne.s 	Dligne
        subq.w 	#1,UNPlan(sp)
        bne.s 	Dplan
        lea	UPile(sp),sp            * Restore the pile
* Finished!
	movem.l	(sp)+,a0-a6/d1-d7
	rts


********************************************************
*		DATA ZONE

*************** Packed screen header
		RsReset
PsCode		rs.l 1
PsTx		rs.w 1
PsTy		rs.w 1
PsAWx		rs.w 1
PsAWy		rs.w 1
PsAWTx		rs.w 1
PsAWTy		rs.w 1
PsAVx		rs.w 1
PsAVy		rs.w 1
PsCon0		rs.w 1
PsNbCol		rs.w 1
PsNPlan		rs.w 1
PsPal		rs.w 32
PsLong		equ __Rs
SCCode		equ $12031990
*************** Packed picture header
		RsReset
Pkcode   	rs.l 1
Pkdx     	rs.w 1
Pkdy     	rs.w 1
Pktx     	rs.w 1
Pkty     	rs.w 1
Pktcar   	rs.w 1
Pknplan		rs.w 1
PkDatas2 	rs.l 1
PkPoint2 	rs.l 1
PkLong  	equ __Rs
PkDatas1	equ __Rs
BMCode		equ $06071963

***********************************************************
* 		COMPACTOR TOKENS
Tk:		dc.w 	1,0
		dc.b 	$80,-1
		dc.w 	Pack2-Tk,1
		dc.b 	"!pac","k"+$80,"I0t0",-2
		dc.w	Pack6-Tk,1
		dc.b	$80,"I0t0,0,0,0,0",-1
		dc.w 	SPack2-Tk,1
		dc.b 	"!spac","k"+$80,"I0t0",-2
		dc.w	SPack6-Tk,1
		dc.b	$80,"I0t0,0,0,0,0",-1
		dc.w	UPack1-Tk,1
		dc.b	"!unpac","k"+$80,"I0",-2
		dc.w 	UPack2-Tk,1
		dc.b	$80,"I0t0",-2
		dc.w 	UPack3-Tk,1
		dc.b	$80,"I0,0,0",-1
		dc.w 	0

*************** Small data zone
TSize:		dc.w 1,2,3,4,5,6,7,8,12,16,24,32,48,64,0
PacAdr:		dc.l 0

*************** Definition banque de samples
BkPac:		dc.b "Pac.Pic."

*************** Welcome message
PacWel:		dc.b 27,"Y",48+9,"Picture compactor V 1.1",0

*************** ERROR MESSAGES
PacErr:		dc.b "Not a packed bitmap",0
		dc.b "Not a packed screen",0

***************
		dc.l	0