← Back to contents
ASCII text
— 5K bytes
— 1990-03-01
'************ PIC-a-PUT-PICTURE ****************
CLEAR,240000&
DEFINT a-j,x-z :DEFLNG k-m :DEFSTR t-w
DIM kveld(5),brush(5123)
DECLARE FUNCTION xOpen& LIBRARY
DECLARE FUNCTION xRead& LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
DECLARE FUNCTION AllocMem&() LIBRARY
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
LIBRARY "intuition.library"
start:
boptel=0 :mode=1 :verr="" :aw=0
PRINT
LINE INPUT"FILENAME ? ";wpic
IF wpic="" THEN uitgang2
GOSUB tekening.laden
IF verr<>""THEN
IF aw THEN
GOTO uitgang
ELSE
GOTO uitgang2
END IF
END IF
bepalen:
MOUSE ON
WHILE MOUSE(0)<>0 :WEND
COMPLEMENT
WHILE MOUSE(0)=0
xmuis=MOUSE(1) :ymuis=MOUSE(2)
LINE (xmuis,ymuis)-(xmuis+127,ymuis%+127),,b
LINE (xmuis,ymuis)-(xmuis+127,ymuis%+127),,b
WEND
x1=xmuis :y1=ymuis
x2=x1+127 :y2=y1+127
COMPLEMENT
IF x1>x2 THEN SWAP x1,x2
IF y1>y2 THEN SWAP y1,y2
GET (x1,y1)-(x2,y2),brush
boptel=boptel+1
IF boptel=1 THEN
WINDOW 3,"",,0,2
ELSE
WINDOW 3 :CALL ActivateWindow&(WINDOW(7)) :CLS
END IF
PUT (10,10),brush
LOCATE INT((y2-y1)/8)+4,2 :INPUT"THE RIGHT CUT (Y/N)";vv
IF vv="n" OR vv="N" THEN WINDOW 2 :CALL ActivateWindow&(WINDOW(7)):GOTO bepalen
LINE INPUT "FILENAME ";vv
OPEN vv FOR OUTPUT AS #1
FOR d=0 TO e
WRITE #1,brush(d)
NEXT d
CLOSE #1
OPEN vv FOR INPUT AS 2
vlengte=INPUT$(LOF(2),2)
CLOSE 2
lengte=LEN(vlengte)
blocks=INT(lengte/483) :IF blocks<>lengte/483 THEN blocks=blocks+1
CLS
PRINT
PRINT vv :PRINT
PRINT"filelenght ="+STR$(lengte)
PRINT"blocks ="+STR$(blocks)
WHILE INKEY$="" :WEND
uitgang:
WINDOW CLOSE 2
SCREEN CLOSE 2 :
uitgang2:
MOUSE STOP :LIBRARY CLOSE :PRINT verr
END
SUB COMPLEMENT STATIC
SHARED mode
IF (mode AND 2)=2 THEN mode=(mode AND 5) ELSE mode=mode+2
CALL SetDrMd& (WINDOW(8),mode)
END SUB
tekening.laden:
kstart = 0 :mbuffer = 0
atest1 = 0 :atest2 = 0 :atest3 = 0 :atest4 = 0 :atest5 = 0
wpic= wpic + CHR$(0)
kstart = xOpen&(SADD(wpic),1005)
IF kstart = 0 THEN
verr="FILE NOT FOUND" :GOTO wegwezen
END IF
kschoon = 65537& :mbuf = 360
mbuffer = AllocMem&(mbuf,kschoon)
IF mbuffer = 0 THEN
verr="NOT ENOUGH MEMORIE TO CREATE BUFFERS" :GOTO wegwezen
END IF
minbuffer = mbuffer :mcbuffer = mbuffer + 120 :mctabel = mbuffer + 240
lengte = xRead&(kstart,minbuffer,12)
thoofd = ""
FOR d = 8 TO 11
ahoofd = PEEK(minbuffer + d)
thoofd = thoofd + CHR$(ahoofd)
NEXT
IF thoofd <> "ACBM" THEN
verr="NOT A ACBM-FILE" :GOTO wegwezen
END IF
nog.een.keer:
lengte = xRead&(kstart,minbuffer,8)
mlengte = PEEKL(minbuffer + 4)
thoofd = ""
FOR d = 0 TO 3
ahoofd = PEEK(minbuffer + d)
thoofd = thoofd + CHR$(ahoofd)
NEXT
IF thoofd = "BMHD" THEN
atest1 = 1
lengte = xRead&(kstart,minbuffer,mlengte)
breedte1 = PEEKW(minbuffer)
hoogte1 = PEEKW(minbuffer + 2)
diepte1 = PEEK(minbuffer + 8)
compr = PEEK(minbuffer + 10)
breedte = PEEKW(minbuffer + 16)
hoogte = PEEKW(minbuffer + 18)
bytes = breedte1 /8 :bytesscherm = breedte / 8 :aantkl = 2^(diepte1)
moeten = FRE(-1) :kmoet = ((breedte/8)*hoogte*(diepte1+1))+5000
IF moeten < kmoet THEN
verr="NOT ENOUGH MEMORIE TO CREATE SCREEN" :GOTO wegwezen
END IF
lhire = &H8000
lace = &H4
d = 1
IF atest3 THEN
IF (lmode AND lhire) THEN d = d+1
IF (lmode AND lace) THEN d = d+2
ELSE
IF breedte >= 640 THEN d = d + 1
IF hoogte >= 400 THEN d = d + 2
END IF
SCREEN 2,breedte,hoogte,diepte1,d
WINDOW 2,"CUTaPUZZLE",,16,2 :aw=-1
GOSUB adressen
CALL LoadRGB4&(kview,mctabel,aantkl)
ELSEIF thoofd = "CMAP" THEN
atest2 = 1
lengte = xRead&(kstart,mcbuffer,mlengte)
FOR d = 0 TO aantkl - 1
cr = PEEK(mcbuffer+(d*3))
cg = PEEK(mcbuffer+(d*3)+1)
cb = PEEK(mcbuffer+(d*3)+2)
czo = (cr*16)+(cg)+(cb/16)
POKEW(mctabel+(2*d)),czo
NEXT
ELSEIF thoofd = "CAMG" THEN
atest3 = 1
lengte = xRead&(kstart,minbuffer,mlengte)
lmode = PEEKL(minbuffer)
ELSEIF thoofd = "ABIT" THEN
atest5 = 1
lgrootte = (breedte/8) * hoogte
FOR e = 0 TO diepte1 -1
lengte = xRead&(kstart,kveld(e),lgrootte)
NEXT
ELSE
FOR d = 1 TO mlengte
lengte = xRead&(kstart,minbuffer,1)
NEXT
IF (mlengte OR 1) = mlengte THEN
lengte = xRead&(kstart,minbuffer,1)
END IF
END IF
IF atest1 AND atest2 AND atest5 THEN
GOTO goed.gedaan
END IF
IF lengte > 0 THEN GOTO nog.een.keer
IF lengte < 0 THEN
GOTO wegwezen
END IF
IF (atest1=0) OR (atest5=0) OR (atest2=0) THEN
GOTO wegwezen
END IF
goed.gedaan:
IF atest2 THEN
CALL LoadRGB4&(kview,mctabel,aantkl)
END IF
wegwezen:
IF kstart <> 0 THEN CALL xClose&(kstart)
IF mbuffer <> 0 THEN CALL FreeMem&(mbuffer,mbuf)
RETURN
adressen:
kwin = WINDOW(7)
ksch = PEEKL(kwin + 46)
kview = ksch + 44
kras = ksch + 84
kleurmap = PEEKL(kview + 4)
kleurtab = PEEKL(kleurmap + 4)
kbit = PEEKL(kras + 4)
breedte = PEEKW(ksch + 12)
hoogte = PEEKW(ksch + 14)
diepte = PEEK(kbit + 5)
aantkl = 2^diepte
FOR d = 0 TO diepte - 1
kveld(d) = PEEKL(kbit+8+(d*4))
NEXT
RETURN