DECLARE SUB SHRINK ()
DECLARE SUB smooth ()
DECLARE SUB SETUPPAL ()
DECLARE SUB scroll (x!, y!, rot!)
DECLARE SUB drawbutton (O!, cc!, c!)
DECLARE SUB clearbutton (O!)
DECLARE SUB clearbuttons ()
DECLARE SUB ADDBUTTON (x!, y!, z$)
DECLARE SUB memcopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
DECLARE FUNCTION button! ()
DECLARE SUB tmpbmp (filename$)
DECLARE SUB change ()
DECLARE SUB LOADSAVEPAL (ld!)
DECLARE SUB loadedpal ()
DECLARE SUB GETBMPPART (x!, y!)
DECLARE SUB bmppal (filename$)
DECLARE SUB LOADBMP (filename$)
DECLARE SUB fl2 (a3!, B3!, fl!)
DECLARE SUB CENTRE (A$)
DECLARE SUB setpalbox ()
DECLARE SUB hidemouse ()
DECLARE SUB showmouse ()
DECLARE FUNCTION BGET! (f!, G!)
DECLARE SUB LNY (y!)
DECLARE SUB setpal ()
DECLARE SUB PAL (w!, RED!, GREEN!, BLUE!)
DECLARE SUB revY ()
DECLARE SUB revx ()
DECLARE SUB setsize (xd!, yd!)
DECLARE SUB confirm (a1$)
DECLARE SUB new ()
DECLARE SUB ln (y!)
DECLARE SUB MESSAGE (a1$)
DECLARE SUB help (A!)
DECLARE SUB big (A$, szx!, szy!, c!, sx!, SY!)
DECLARE SUB hlp (A$)
DECLARE SUB intro ()
DECLARE SUB fill (A!, b!)
DECLARE SUB save ()
DECLARE SUB setup ()
DECLARE SUB load ()
DECLARE SUB REPUT ()
DECLARE SUB ssprite ()
DECLARE SUB net ()
DECLARE SUB disp (A!, b!)
DECLARE SUB cx (x!, y!)
DECLARE SUB chkxy ()
DECLARE SUB mk (xx!)
DECLARE SUB selc ()
DECLARE SUB empty ()
DECLARE SUB ccolour (x!)
DECLARE SUB BACK (sc!)
'$INCLUDE: 'DIRECTQB.BI'
'$DYNAMIC
CLEAR , , 5000
DIM SHARED pnt AS STRING * 1, pointerx AS STRING * 320, pointerstr AS STRING * 1, RE(255), GN(255), BL(255), bmx, bmy, shift, mbx, mby, HD, OBX, OBY, ptx, pty
DIM SHARED sprite$, ver$, DARRAY(512) AS INTEGER, base$, hmx, hmy, clx(255), cly(255), lb, rb, osc, sn, lx, ly, sny, sox, soy, eox, eoy, pt, sgx, sgy, CHD, acc, opb
acc = 26
IF INSTR(COMMAND$, "ADULT") THEN ADULT = 1: base$ = "adult\" ELSE base$ = "kids\"
ver$ = "V3.1"
OPEN "path.dat" FOR INPUT AS #1: INPUT #1, sprite$: CLOSE
sprite$ = sprite$
m1 = 1
m2 = 1
'$DYNAMIC
DIM SHARED N$, yes, no, ld, lox, msx, msy, ss, h$, st, h$(20), ch, fl, fx, ex, bc, dr$, ff, b((80 * 80) * 2), t, sc, mvx, mvy, A(80, 80), BLC(80, 80), xl, YL, MX, MY, smx, smy, x, y, OX, OY, sx, SY, x11, y11, omx, omy, asgx, asgy, OC(255), bx(100),  _
by(100), bz(100), bt$(100), rd1 AS INTEGER, bl1 AS INTEGER, gn1 AS INTEGER, rd2 AS INTEGER, bl2 AS INTEGER, gn2 AS INTEGER
DEF SEG = 0
h$(1) =  _
"Drawing:(Arrows) move:(Enter) draws: (C) Change This Color +(0-9) (S) saves  (L) loads  (N) nets current sprite (T) Temporarily stores sprite (r) Refreshes (G) or left click in palette:gets colour from current position (b) or Right click: Fill line of colour with (b) continued: user colour. (X) Reverse on X" _

h$(2) = "Arrows move, Enter selects colour"
h$(3) = "Enter colour number: enter is USER COL."
h$(4) = "(f1) start 16 BY 16  (f2) 32 by 32 (f3) 64 by 64"
DQBclose: e = DQBinit(2, 0, 0)
CALL intro
dr$ = "spr"
OX = m1
MX = m1
MY = m2
sx = 5
SY = 12
SWO = 1
TIMER ON
ON TIMER(3) GOSUB ph
KEY 15, CHR$(0) + CHR$(1)
KEY 16, CHR$(0) + CHR$(66)
KEY(16) ON
KEY(15) ON
ON KEY(15) GOSUB ersort
ON KEY(16) GOSUB svpc
SCREEN 12
cont:
CALL setup
DQBresetMouse
DQBsetMousePos 160, 100
DO
A$ = INKEY$: sc$ = "": IF LEN(A$) = 2 THEN sc$ = RIGHT$(A$, 1): GOTO cnt
IF A$ <> "" THEN IF ASC(A$) < 91 AND ASC(A$) > 64 THEN A$ = CHR$(ASC(A$) + 32)
lb = DQBmouseLB
rb = DQBmouseRB
omx = ptx
omy = pty
ptx = DQBmouseX: pty = DQBmouseY
IF (lb OR rb) AND ptx > sx AND pty > SY AND ptx < ((MX + 1.3) * xl) AND pty < SY + ((MY + 1) * YL) THEN  ELSE GOTO nomouse
x = ((ptx - sx) \ xl)
y = (pty - SY) \ YL
chkxy
IF lb THEN A$ = CHR$(13)
IF rb THEN fill x, y

nomouse:
IF lb THEN IF ptx > sox AND pty > soy AND ptx < eox AND pty < eoy THEN selc
IF A$ = CHR$(13) THEN A = sc: GOTO cnt
IF A$ = "" THEN GOTO cnt
A = VAL(A$): IF A = 0 AND A$ <> "0" THEN A = -1
cnt:
PAL 247, INT(RND * 50), 0, INT(RND * 50)
IF sc$ = "I" THEN A = -1
IF A <> -1 THEN CALL mk(A): IF A = 0 OR SWO THEN A = -1
IF sc$ = ";" THEN setsize 16, 16
IF sc$ = "<" THEN setsize 32, 32
IF sc$ = "=" THEN setsize 63, 63
IF sc$ = ">" THEN new
IF sc$ = "k" THEN GOTO syst
c = 0: IF A$ = ">" OR A$ = "." THEN c = .2
IF A$ = "<" OR A$ = "," THEN c = -.2
IF c THEN sgx = sgx + c: sgy = sgy + c
IF sgx < .1 THEN sgx = .1 ELSE IF sgx > asgx * 8 THEN sgx = asgx * 8
IF sgy < .1 THEN sgy = .1 ELSE IF sgy > asgy * 8 THEN sgy = asgy * 8
IF c <> 0 THEN GETBMPPART bmx, MY: REPUT
IF shift THEN IF A$ = "!" OR A$ = "1" THEN sgx = asgx: sgy = asgy: GETBMPPART bmx, bmy: REPUT
IF shift THEN IF A$ = "2" OR A$ = CHR$(34) THEN sgx = 1: sgy = 1: GETBMPPART bmx, bmy: REPUT
IF A$ = "a" THEN base$ = "adult\"
IF A$ = "k" THEN base$ = "kids\"
IF A$ = "p" AND SWO = 1 THEN SWO = 0 ELSE IF A$ = "p" AND SWO = 0 THEN SWO = 1
IF A$ = "c" THEN change
'IF a$ = "c" THEN selc
IF A$ = "s" THEN save
IF A$ = "l" THEN CALL load: CALL REPUT
IF A$ = "t" THEN CALL ssprite
IF A$ = "n" THEN CALL net
IF A$ = "x" THEN revx
IF A$ = "y" THEN revY
IF A$ = "f" THEN CALL fill(x, y)
IF A$ = "b" THEN ln y
IF A$ = "v" THEN LNY x
IF A$ = "g" THEN sc = A(x, y): ccolour (sc)
IF A$ = "r" THEN REPUT
IF A$ <> "" THEN CALL empty
IF ld <> 0 THEN CALL cx(x, y) ELSE help (4): MESSAGE "Press F1/f2/f3 to start."
IF ld <> 0 THEN CALL help(1)
LINE (10, 190)-(310, 198), 4, BF
DQBprints 0, base$ + sprite$, 10, 190, 7, 0
shift = (PEEK(1047) AND 1): IF (PEEK(1047) AND 2) = 2 THEN shift = 1
d = (sc$ = "H") - (sc$ = "P")
c = (sc$ = "K") - (sc$ = "M")
IF shift = 0 THEN x = x11 + c: y = y11 + d
x11 = x: y11 = y
IF shift THEN bmx = bmx + c: bmy = bmy + d
IF shift THEN IF ptx <> omx OR pty <> omy THEN c = 1: d = 1: bmx = ptx: bmy = pty
IF (c OR d) AND shift THEN GETBMPPART bmx, bmy
chkxy
BP = button: IF lb = 0 AND rb = 0 THEN BP = 0
IF BP = 2 THEN scroll -1, 0, 0
IF BP = 1 THEN scroll 1, 0, 0
IF BP = 3 THEN scroll 0, 1, 0
IF BP = 4 THEN scroll 0, -1, 0
IF BP = 5 THEN scroll 0, 0, 1
IF BP = 6 THEN scroll 0, 0, 2
IF BP = 7 THEN smooth
IF BP = 8 THEN SHRINK
DQBmouseShow
LOOP UNTIL 0
ersort:
ex = 1
RETURN
svpc:
BSAVE "screen.dat", 32768, 30000
RETURN
ph:
IF h$ = "" THEN RETURN
COLOR 15
pp = INSTR(h$, "(")
h$ = MID$(h$, 2)
pp = INSTR(h$, "(")
IF pp = 0 THEN pp = 1
h$ = MID$(h$, pp): LOCATE 1, 1: PRINT STRING$(40, " "): LOCATE 1, 1: PRINT MID$(h$, 1, 40);
IF LEN(h$) < 40 THEN h$ = h$(ch)
RETURN
mistake:
setup
MESSAGE "File is of incorrect type."
DO: LOOP UNTIL INKEY$ = " ":
N$ = "DEFAULT.spr": RESUME
GOTO cont
syst:
CHAIN "menu"

REM $STATIC
SUB ADDBUTTON (x, y, z$)
FOR O = 1 TO 100
IF bx(O) <> 0 OR by(O) <> 0 OR bz(O) <> 0 THEN GOTO nt
bx(O) = x: by(O) = y: bz(O) = DQBlen(z$)
bt$(O) = z$
drawbutton O, 1, acc
O = 101
nt:
NEXT
END SUB

SUB BACK (sc!)
BLOAD "bACKGND.SHT"
EXIT SUB
P = 320 / 110
c = sc + 40
FOR O = 0 TO 320 STEP P
LINE (O, 0)-(O + P, 200), c, BF
c = c + 1: ' IF c > (sc + (32 - 9)) THEN c = sc
NEXT
DEF SEG = &HA000
BSAVE sprite$ + "backgnd.sht", 0, 64000
END SUB

FUNCTION BGET (f, G)
IF TP = 1 THEN GET #f, , G
END FUNCTION

SUB big (AB$, szx, szy, c, sx, SY)
A$ = AB$
lg = 1
hx = 4
hx = hx * szy
hc = 6
LOCATE 1, 1
IF sx <> -1 GOTO 1
sx = 320 - ((LEN(A$) - 1) * 16)
1
DQBprint 0, A$, 0, 0, 0 + c
FOR O = 0 TO (16 * LEN(A$) - 1)
FOR P = 0 TO 6
p1 = POINT(O, P)
Q = sx + ((O * szx) / 2)
R = SY + P * szy
pp = (320 - Q) / 16
Q = Q + (pp * (P / 10))
IF p1 THEN LINE (Q + hx, R + hx)-(Q + szx + hx * lg, R + szy + hx * lg), hc, BF: LINE (Q, R)-(Q + szx * (lg - .5), R + szy * lg), c, BF
NEXT
IF (O + 2) MOD 8 = 0 THEN O = O + 1
A$ = INKEY$
IF A$ <> "" THEN O = 900: fx = 1
NEXT
LOCATE 1, 1: PRINT STRING$(40, " ");
END SUB

SUB bmppal (filename$)
CLOSE #16
OPEN filename$ FOR BINARY AS #16
IF LOF(16) < 2 THEN EXIT SUB
GET #16, 54, pointerstr
'GET #1, 54, pointeR
FOR SLOT% = 0 TO 255
GET #16, , pointerstr
 BL% = INT(ASC(pointerstr) / 4)
 GET #16, , pointerstr
 GR% = INT(ASC(pointerstr) / 4)
 GET #16, , pointerstr
 RE% = INT(ASC(pointerstr) / 4)
  IF BL% = GR% AND GR% = RE% AND RE% > 63 THEN GOTO notthis
  BL(SLOT%) = BL%
  GN(SLOT%) = GR%
  RE(SLOT%) = RE%
  OC(SLOT%) = DQBfindCol(RE%, GR%, BL%)
notthis:
 GET #16, , pointerstr
NEXT SLOT%
CLOSE #16
END SUB

FUNCTION button
ee = 0: FOR O = 1 TO 100
IF ptx > bx(O) AND ptx < bx(O) + bz(O) AND pty > by(O) AND pty < by(O) + 8 THEN ee = O
NEXT
IF opb <> ee AND opb <> 0 AND opb < 101 THEN drawbutton opb, 1, acc: obp = 0
IF ee > 0 THEN IF lb OR rb THEN drawbutton ee, 0, acc: opb = ee
button = ee
END FUNCTION

SUB ccolour (x!)
EXIT SUB
b$ = CHR$(219)
COLOR 15
LOCATE 23, 19
PRINT ; CHR$(25);
LOCATE 24, 1
PS = 1
FOR O = x - 18 TO x + 20: oo = O: IF oo < 0 THEN oo = 255 + oo
oo = oo MOD 256: COLOR oo: PRINT ; b$; : NEXT
sc = x
END SUB

SUB CENTRE (A$)
DQBprints 0, A$, 160 - DQBlen(A$) / 2, CSRLIN * 8, 15, BOLD
DQBprints 0, A$, 161 - DQBlen(A$) / 2, (CSRLIN * 8) - 1, 4, BOLD
PRINT
END SUB

SUB change
e = A(x, y)
FOR O = 0 TO MX
FOR P = 0 TO MY
IF A(O, P) = e THEN A(O, P) = sc
NEXT
NEXT
REPUT
END SUB

SUB chkxy
IF x < 0 THEN x = 0 ELSE IF x > MX THEN x = MX
IF y < 0 THEN y = 0 ELSE IF y > MY THEN y = MY
bmx = INT(bmx)
bmy = INT(bmy)
IF bmx < -16 THEN bmx = 0 ELSE IF bmx > mbx THEN bmx = mbx
IF bmy < -16 THEN bmy = 0 ELSE IF bmy > mby THEN bmy = mby
END SUB

SUB clearbutton (O)
bx(O) = 0: by(O) = 0: bz(O) = 0
END SUB

SUB clearbuttons
FOR O = 0 TO 100: clearbutton O
NEXT
END SUB

SUB confirm (a1$)
A$ = " " + a1$ + " (y/n) "
mx1 = 640: my1 = 400
DO: mx1 = mx1 / 2: my1 = my1 / 2: LOOP UNTIL POINT(mx1, my1) > -1
msx = mx1 / 8
msy = my1 / 16
IF msx < 1 THEN msx = 40
IF msy < 1 THEN msy = 15
lox = msx - (LEN(A$) / 2)
IF lox < 1 THEN lox = 1
lox = lox + 1: msy = msy + 1
IF lox < 1 THEN lox = 1
COLOR 8
LOCATE msy - 1, lox - 1: PRINT ; CHR$(219) + STRING$(LEN(A$), CHR$(219)) + CHR$(219)
LOCATE msy, lox - 1: PRINT ; CHR$(219); : COLOR 15: PRINT ; A$; : COLOR 8: PRINT CHR$(219)
COLOR 8
LOCATE msy + 1, lox - 1: PRINT ; CHR$(219) + STRING$(LEN(A$), CHR$(219)) + CHR$(219)
DO: A$ = INKEY$: LOOP UNTIL A$ = "y" OR A$ = "n" OR A$ = "Y" OR A$ = "N"
IF A$ = "y" OR A$ = "Y" THEN yes = 1: no = 0 ELSE yes = 0: no = 1
END SUB

SUB cx (x!, y!)
hidemouse
IF OX = x AND OY = y GOTO ed
IF A(x, y) = 15 THEN cll = 7 ELSE cll = 15
LINE (sx + (OX * xl), SY + (OY * YL))-(sx + ((OX + 1) * xl) - 1, SY + ((OY + 1) * YL - 1)), A(OX, OY), BF
LINE (sx + (x * xl) + 1, SY + (y * YL) + 1)-(sx + ((x + 1) * xl) - 1, SY + ((y + 1) * YL - 1)), cll, BF
mvx = 0: mvy = 0
OX = x: OY = y
ed:
showmouse
END SUB

SUB disp (A!, b!)
IF A > 0 AND A < 300 AND b > 0 AND b < 200 THEN PUT (A, b), b(0), XOR
END SUB

SUB drawbutton (o2, cc, c)
hidemouse
tmpx = x: tmpy = y
x = bx(o2): y = by(o2)
LINE (x - 2, y - 2)-STEP(bz(o2) + 4, 12), c - cc * 3, BF
LINE (x - 1, y - 1)-STEP(bz(o2) + 2, 10), c - cc, BF
LINE (x, y)-STEP(bz(o2), 8), c, BF
DQBprint 0, bt$(o2), 1 + x, 1 + y, 4:
x = tmpx: y = tmpy
showmouse
END SUB

SUB empty
t = t + 1: IF t < 5 THEN GOTO edproc
t = 0
DO
c$ = INKEY$
LOOP UNTIL c$ = ""
edproc:
END SUB

SUB fill (A, b)
bc = A(A, b)
flr = 0
fln = 0
sa = A: sb = b
CALL help(3)
LOCATE 25, 1
PRINT "FILL: (0-9) or ENTER";
CALL empty
IF rb THEN fl = sc: GOTO justfill
DO
A$ = INKEY$
LOOP UNTIL VAL(A$) > 0 OR (VAL(A$) = 0 AND A$ = "0") AND VAL(A$) < 10 OR A$ = CHR$(13) OR ex = 1: IF ex = 1 GOTO CNTN
'PLAY "l30o5a"
IF A$ = CHR$(13) THEN fl = sc ELSE fl = VAL(A$)
justfill:
MESSAGE "Filling..."
LOCATE 23, 1
PRINT " Colr:"; fl;
CNTN:
bc = A(A, b)
IF bc = fl THEN GOTO nofill:
fl2 A, b, fl
nofill:
CALL setup
CALL REPUT
END SUB

SUB fl2 (a3!, B3!, fl)
A(a3!, B3!) = fl
pt = pt + 1
'PRINT pt
IF pt > 100 THEN pt = pt - 1: EXIT SUB
c = -1: d = -1
lp:
e = a3! + c
f = B3! + d
IF e < 0 THEN e = 0 ELSE IF e > MX THEN e = MX
IF f < 0 THEN f = 0 ELSE IF f > MX THEN f = MX
IF (c = 0 OR d = 0) THEN IF A(e, f) = bc THEN fl2 e, f, fl
c = c + 1: IF c > 1 THEN c = -1: d = d + 1
IF d < 2 THEN GOTO lp
pt = pt - 1
END SUB

SUB GETBMPPART (x, y)
hidemouse
'ssprite
x = INT(x): y = INT(y)
FOR O = 0 TO MX
FOR P = 0 TO MY: IF CHD THEN IF sgx = 1 AND sgy = 1 THEN dqbPSET 2, INT(OBX + O), INT(OBY + P), A(O, P)
A(O, P) = DQBpoint(2, (O * sgx) + x, (P * sgy) + y)
NEXT
NEXT
OBX = x: OBY = y
showmouse
REPUT
CHD = 0
END SUB

SUB help (A)
IF A <> ch THEN ch = A ELSE GOTO eoh
hlp h$(A)
eoh:
END SUB

SUB hidemouse
hmx = DQBmouseX
hmy = DQBmouseY
DQBmouseHide
END SUB

SUB hlp (A$)
LOCATE 1, 1
COLOR 15
PRINT STRING$(40, " "); : LOCATE 1, 1: PRINT MID$(A$, 1, 40): LOCATE 1, 1
G$ = A$
st = 0
END SUB

SUB intro
SCREEN 13
TIMER ON
PAL 0, 0, 40, 0
PALETTE 15, 0
e = DQBloadFont("hitech.fnt")
LOCATE 1, 1
CENTRE "SPRITE DESIGNER"
PRINT
CENTRE ver$
PRINT
CENTRE "By DAMIEN STURDY"
PRINT
CENTRE "2001 RELEASE FOR GAMES FACTORY"
PRINT
CENTRE "now with BITMAP support"
A$ = "WELCOME TO DAMIEN STURDYS SPRITE DESIGNER " + ver$ + " THE ALL NEW VERSION FOR 2001! YOU WILL BE GLAD TO HEAR THAT HELP IS STILL AVALIABLE BUT NOW THERES MOUSE SUPPORT!"
A$ = STRING$(40, " ") + A$ + STRING$(40, " ")
DQBsetFrameRate (60)
redo:
FOR o1 = 0 TO LEN(A$) * 8 STEP .5
tt = TIMER
LOCATE 21, 1
DQBwait 1
LINE (0, 100)-(640, 108), 0, BF
DQBprint 0, A$, 0 - o1, 100, 7
DQBprint 0, A$, 1 - o1, 100, 15
DO: c$ = INKEY$: LOOP UNTIL DQBframeReady OR c$ <> ""
IF c$ <> "" THEN o1 = LEN(A$) * 9: EXIT FOR
NEXT
IF o1 < (LEN(A$) + 9) THEN GOTO redo
edi:
FOR O = 0 TO 20: h$(O) = " " + h$(O)
NEXT
SCREEN 13
END SUB

SUB ln (y!)
xx = x: yy = y
bk = A(x, y)
FOR x = 0 TO MX
IF A(x, y) = bk THEN cx x, y: mk sc
NEXT
x = xx: y = yy
END SUB

SUB LNY (x!)
xx = x: yy = y
bk = A(x, y)
FOR y = 0 TO MY
IF A(x, y) = bk THEN cx x, y: mk sc
NEXT
x = xx: y = yy
END SUB

SUB load
DQBmouseHide
CLOSE
SCREEN 9
OX = 1: OY = 1
x1 = x: y1 = y
ct:
COLOR 15
CLS
PRINT "Sprite files in current:"
PRINT "Path:";
FILES base$ + sprite$ + "*." + dr$
PRINT
'ON ERROR GOTO mistake
DO: INPUT "Enter LOAD Filename: "; N$: IF INSTR(N$, ".") = 0 THEN ff = 9 ELSE ff = 13
LOOP UNTIL LEN(N$) < ff
IF INSTR(N$, ".") = 0 THEN N$ = N$ + "." + dr$ ELSE IF LEFT$(N$, 1) = "." THEN dr$ = MID$(N$, INSTR(N$, ".") + 1): GOTO ct
N$ = LCASE$(N$)
IF N$ = ".spr" THEN N$ = "default.spr"
IF RIGHT$(N$, 4) = ".bmp" THEN LOADBMP base$ + sprite$ + N$: N$ = "default.spr"
IF N$ = "default.spr" THEN CALL setup: CALL REPUT: GOTO ed2
OPEN base$ + sprite$ + N$ FOR BINARY AS #1
TP = 1: IF LOF(1) = 0 THEN CLOSE #1: KILL base$ + sprite$ + N$: setup: MESSAGE "File Doesn't Exist.": DO: LOOP UNTIL INKEY$ <> " ": setup: REPUT: EXIT SUB
CLOSE #1
OPEN base$ + sprite$ + N$ FOR BINARY AS #1
CALL setup
GET #1, , mm: GET #1, , m1: GET #1, , m2: IF m1 = 0 THEN m1 = m2
IF m1 <> MX OR m2 <> MY THEN mm = MX: mm2 = MY: MX = m1: MY = m2: setup: MX = mm: MY = mm2
IF m1 > 100 OR m2 > 100 THEN MESSAGE " Error: File incorrect size.": DO: LOOP UNTIL INKEY$ = " ": CALL setup: GOTO ed2
FOR O = 0 TO m1: FOR P = 0 TO m2: GET #1, , A(O, P): NEXT: NEXT
mm = MX: mm2 = MY: MX = m1: MY = m
2
CALL REPUT
IF m1 = 0 OR m2 = 0 THEN MX = mm: MY = mm2: GOTO ed2
MX = m1: MY = m2
ff = 0
ed2:
CLOSE
IF MX > 32 THEN MX = 32
IF MY > 32 THEN MY = 32
DQBmouseShow
END SUB

SUB LOADBMP (filename$)
h$ = ""
SCREEN 13
PAL 0, 46, 32, 64
PAL 7, 0, 0, 0
SETUPPAL
LOADSAVEPAL 2
bmppal filename$
CLOSE
OPEN filename$ FOR BINARY AS #16
IF LOF(16) < 2 THEN EXIT SUB
GET #16, 1078, pointerstr
'FOR Slot% = 0 TO 255
' GET #16, , pointerstr
' GET #16, , pointerstr
' GET #16, , pointerstr
' GET #16, , pointerstr
'NEXT Slot%
yI% = 198
DO
GET #16, , pointerx
GOSUB pointset
yI% = yI% - 1
LOOP UNTIL yI% = 0
DEF SEG = &HA000
DO: A$ = INKEY$: LOOP UNTIL A$ <> ""
e = ASC(A$) - 48: IF e > 0 AND A < 10 THEN BSAVE base$ + sprite$ + "BACKG" + A$ + ".sht", 0, 64000
bmx = 0
bmy = 0
DQBcopyLayer 0, 2
DEF SEG = 0
CHD = 0
GETBMPPART bmx, bmy
EXIT SUB
pointset:
xI% = 0
IF MX < 16 AND MY < 16 THEN MX = 16: MY = 16: ld = 1
DO: asgx = 40 / MX: asgy = 39 / MY: sgx = 1: sgy = 1: c = ASC(MID$(pointerx, xI% + 1, 1)): c = OC(c): IF c = 247 THEN c = 254
IF c > 0 THEN PSET (xI%, yI%), c: xI% = xI% + 1
LOOP UNTIL xI% >= 319
mbx = 319 / sgx
mby = 200 / sgy
RETURN
END SUB

SUB loadedpal
EXIT SUB
FOR O = 180 TO 255
IF RE(O) <> 0 OR BL(O) <> 0 OR GN(O) <> 0 THEN PAL O, RE(O), GN(O), BL(O)
NEXT
END SUB

SUB LOADPIC

END SUB

SUB LOADSAVEPAL (ld)
OPEN "palette.dat" FOR BINARY AS #10
FOR O = 180 TO 180 + 66
IF ld = 1 THEN PUT #10, , RE(O): PUT #10, , BL(O): PUT #10, , GN(O)
IF ld = 2 THEN GET #10, , RE(O): GET #10, , BL(O): GET #10, , GN(O): IF (RE(O) <> 63 OR BL(O) <> 63 OR GN(O) <> 63) THEN PAL O, RE(O), GN(O), BL(O)
NEXT
CLOSE #10
END SUB

SUB memcopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
  asm$ = ""
  asm$ = asm$ + CHR$(85)
  asm$ = asm$ + CHR$(137) + CHR$(229)
  asm$ = asm$ + CHR$(30)
  asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(10)
  asm$ = asm$ + CHR$(142) + CHR$(192)
  asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(14)
  asm$ = asm$ + CHR$(142) + CHR$(216)
  asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(8)
  asm$ = asm$ + CHR$(139) + CHR$(126) + CHR$(12)
  asm$ = asm$ + CHR$(139) + CHR$(78) + CHR$(6)
  asm$ = asm$ + CHR$(243)
  asm$ = asm$ + CHR$(164)
  asm$ = asm$ + CHR$(31)
  asm$ = asm$ + CHR$(93)
  asm$ = asm$ + CHR$(203)
  WAIT &H3DA, 8
DEF SEG = VARSEG(asm$)
    CALL Absolute(BYVAL fromseg%, BYVAL fromoffset%, BYVAL toseg%, BYVAL tooffset%, BYVAL bytes%, SADD(asm$))
  DEF SEG

END SUB

SUB MESSAGE (a1$)
SCREEN 13
A$ = " " + a1$ + " "
mx1 = 640: my1 = 400
DO: mx1 = mx1 / 2: my1 = my1 / 2: LOOP UNTIL POINT(mx1, my1) > -1
msx = mx1 / 8
msy = my1 / 16
IF msx < 1 THEN msx = 40
IF msy < 1 THEN msy = 15
lox = msx - (LEN(A$) / 2)
IF lox < 1 THEN lox = 1
lox = lox + 1: msy = msy + 1
IF lox < 1 THEN lox = 1
COLOR 8
LOCATE msy - 1, lox - 1: PRINT ; CHR$(219) + STRING$(LEN(A$), CHR$(219)) + CHR$(219)
LOCATE msy, lox - 1: PRINT ; CHR$(219); : COLOR 4: PRINT ; A$; : COLOR 8: PRINT CHR$(219)
COLOR 8
LOCATE msy + 1, lox - 1: PRINT ; CHR$(219) + STRING$(LEN(A$), CHR$(219)) + CHR$(219)
END SUB

SUB mk (xx!)
hidemouse
A(x, y) = xx
PSET (smx + x, smy + y), xx
ff = 0
CHD = 1
showmouse
END SUB

SUB net
IF ff = 0 THEN CALL ssprite
CLS
FOR O = 0 TO 300 - MX STEP MX + 1
FOR P = 0 TO 200 - MY STEP MY + 1
CALL disp(O, P)
NEXT
NEXT
LOCATE 25, 1
PRINT "Press SPACE to continue";
DO: LOOP UNTIL INKEY$ = " "
CALL setup
CALL REPUT
endos:
END SUB

SUB new
IF ld = 0 THEN EXIT SUB
confirm "Start new: Are you sure?"
IF yes THEN  ELSE GOTO ednw
FOR O = 0 TO 40: FOR P = 0 TO 40: A(O, P) = 0: NEXT: NEXT
IF yes THEN MX = 1: MY = 1: ld = 0
ednw:
setup
REPUT
END SUB

SUB p. (A$)
PRINT A$
END SUB

SUB PAL (w, RED, GREEN, BLUE)
  IF BLUE < 0 THEN BLUE = 0 ELSE IF BLUE > 64 THEN BLUE = 64
  IF RED < 0 THEN RED = 0 ELSE IF RED > 64 THEN RED = 64
  IF GREEN < 0 THEN GREEN = 0 ELSE IF GREEN > 64 THEN GREEN = 64
  BLUE = INT(BLUE): GREEN = INT(GREEN): RED = INT(RED)
  OUT &H3C8, w
  OUT &H3C9, RED
  OUT &H3C9, GREEN
  OUT &H3C9, BLUE
END SUB

SUB printtab (x1, y1, A$)
PRINT x1, x2
LOCATE x1 + 1, y1 + 1: PRINT A$
END SUB

SUB REPUT
SCREEN 13
hidemouse
x2 = x: y2 = y
OX = 0: OY = 0: FOR x = 0 TO MX: FOR y = 0 TO MY
dqbboxf 0, sx + (x * xl), SY + (y * YL), sx + ((x + 1) * xl) - 1, SY + ((y + 1) * YL - 1), A(x, y): dqbPSET 0, smx + x, smy + y, A(x, y)
OX = x: OY = y: NEXT: NEXT
x = 1: y = 1: OX = 2: OY = 1
DQBmouseShow
showmouse
DQBresetMouse
DQBmouseShow
END SUB

SUB revx
CLS
FOR O = 0 TO MX: FOR P = 0 TO MY
PSET (30 + O, 30 + P), A(MX - O, P)
NEXT
NEXT
FOR O = 0 TO MX: FOR P = 0 TO MY: A(O, P) = POINT(30 + O, 30 + P): NEXT: NEXT
setup
REPUT
END SUB

SUB revY
CLS
FOR O = 0 TO MX: FOR P = 0 TO MY
PSET (30 + O, 30 + P), A(O, MY - P)
NEXT
NEXT
FOR O = 0 TO MX: FOR P = 0 TO MY: A(O, P) = POINT(30 + O, 30 + P): NEXT: NEXT
setup
REPUT
END SUB

SUB save
DQBmouseHide
IF ff = 0 THEN CALL ssprite
SCREEN 9
CLS
PRINT "Sprite files in current:"
PRINT "Path:";
FILES base$ + sprite$ + "*." + dr$
DO: INPUT "Enter SAVE Filename: "; N$: IF INSTR(N$, ".") = 0 THEN ff = 9 ELSE ff = 13
LOOP UNTIL LEN(N$) < ff
IF N$ = "" THEN GOTO edp
IF INSTR(N$, ".") = 0 THEN N$ = N$ + ".spr"
xx = 320 / (MX * MY)
OPEN base$ + sprite$ + N$ FOR BINARY AS #1
O = 0: PUT #1, , O: PUT #1, , MX: PUT #1, , MY
FOR O = 0 TO MX: FOR P = 0 TO MY
PUT #1, , A(O, P): NEXT: NEXT
FOR pp = 0 TO (MX * MY) * 2
LINE (pp * xx, 50)-(pp * xx, 75), 15
PUT #1, , b(pp): NEXT
CLOSE
edp:
CALL setup
CALL REPUT
endofsub:
DQBmouseShow
END SUB

SUB scroll (x, y, rot)
zm = 1: IF rot = 2 THEN rot = 0: zm = 1 ELSE GOTO scroller
IF MX < 64 AND MY < 64 THEN  ELSE GOTO cantdothat
imx = MX: imy = MY
IF MX < 32 THEN MX = 32: MY = 32 ELSE MX = 64: MY = 64
xv = (MX / imx)
yv = (MY / imy)
FOR O = 0 TO imx: FOR P = 0 TO imy: BLC(O, P) = A(O, P)
NEXT: NEXT
setup
FOR O = 0 TO MX: FOR P = 0 TO MY: A(O, P) = BLC(O \ xv, P \ yv): NEXT: NEXT: GOTO cantdothat
scroller:
t = TIMER
FOR O = 0 TO MX: FOR P = 0 TO MY
ex = O + x: ey = P + y
IF ex < 0 THEN ex = (MX + ex) + 1
IF ey < 0 THEN ey = (MY + ey) + 1
ex = ex MOD (MX + 1)
ey = ey MOD (MY + 1)
BLC(ex, ey) = A(O, P)
NEXT: NEXT
FOR O = 0 TO MX
FOR P = 0 TO MY
IF rot = 0 THEN A(O, P) = BLC(O, P)
IF rot > 0 THEN A(O, P) = BLC(P, O)
NEXT: NEXT
DO: LOOP UNTIL TIMER > t + .2 OR DQBmouseLB = 0
cantdothat:
REPUT
END SUB

SUB selc
osc = sc
IF lb THEN hidemouse: LINE (clx(sc), cly(sc))-STEP(sn, sn - 1), sc, B: showmouse: ssc = POINT(DQBmouseX, DQBmouseY - 1): ccolour ssc: IF ssc > 0 THEN sc = ssc: hidemouse: LINE (clx(sc), cly(sc))-STEP(sn, sn - 1), 15, B: showmouse
IF lb THEN showmouse: EXIT SUB
cc = sc
TIMER OFF
CALL help(2)
DO
A$ = INKEY$: b$ = MID$(A$, 2, 1)
CALL empty
IF b$ = "M" THEN sc = sc + 1
IF b$ = "K" THEN sc = sc - 1
IF sc < 0 THEN sc = 256 + sc
sc = sc MOD 256
CALL ccolour(sc)
LOOP UNTIL A$ = " " OR A$ = CHR$(13)
TIMER ON
hidemouse
END SUB

SUB setpalbox
sox = 200
soy = SY
eox = 0: eoy = 0
sn = INT(((300 - sox) / 16) / 8) * 8
sn = 7
sny = sn + 1
x = sox
y = soy
FOR O = 0 TO 255
LINE (x, y)-STEP(sn, sny - 1), 7, B
LINE (x, y)-STEP(sn, sny - 1), O, BF
clx(O) = x: cly(O) = y
x = x + sn: IF x > 308 THEN x = sox: y = y + sny
IF x > eox THEN eox = x
IF y > eoy THEN eoy = y
NEXT
eox = eox + sn
LINE (sox - 1, soy - 1)-(eox + 1, eoy), 7, B
O = 0: x = 0: y = 0
END SUB

SUB setsize (xd, yd)
'IF ld = 1 THEN EXIT SUB
MX = xd: MY = yd: ld = 1: setup
REPUT
END SUB

SUB setup
BTY = 160
hidemouse
IF MX = 0 OR MY = 0 THEN MX = 16: MY = 16
xl = 150 / MX
xl = xl / 1.2
YL = 110 / MY
xl = 1 + FIX(xl): YL = 1 + FIX(YL)
IF POINT(321, 200) <> -1 THEN SCREEN 13
CALL BACK(1)
CALL ccolour(sc)
yx = yx + YL
IF ld = 0 THEN GOTO cntnue
LINE (sx - 1, SY - 1)-(sx + ((MX + 1) * xl), SY + ((MY + 1) * YL)), 0, BF
LINE (sx - 1, SY - 1)-(sx + ((MX + 1) * xl), SY + ((MY + 1) * YL)), 15, B
cntnue:
yx = yx - YL
smx = 1 + (sx + (MX + 1) * xl)
smy = 4 + SY + ((MY + 1) * YL)
smy = 50
LINE (smx, smy)-(smx + MX, smy + MY), 0, BF
LINE (smx - 1, smy - 1)-(smx + MX + 1, smy + MY + 1), 15, B
oo = 63 / (249 - 255)
SETUPPAL
CALL help(1)
clearbuttons
LINE (4, BTY - 4)-(315, BTY + 12), 17, BF
ADDBUTTON 8, BTY, CHR$(16)
ADDBUTTON 28, BTY, CHR$(17)
ADDBUTTON 48, BTY, CHR$(31)
ADDBUTTON 68, BTY, CHR$(30)
ADDBUTTON 88, BTY, "Rotate"
ADDBUTTON 148, BTY, "Zoom"
ADDBUTTON 188, BTY, "Smooth"
ADDBUTTON 240, BTY, "Srink"
setpalbox
LOADSAVEPAL 2
showmouse
END SUB

SUB SETUPPAL
P = 0
FOR O = 248 TO 255
PALETTE O, P: P = P + 9: NEXT
PAL 0, 50, 0, 50
PAL 247, 50, 0, 50
loadedpal
PAL 7, 0, 0, 0
END SUB

SUB showmouse
DQBmouseShow
END SUB

SUB SHRINK
FOR O7 = 0 TO MX: FOR P7 = 0 TO MY: BLC(O7, P7) = 0: NEXT: NEXT
O7 = 0: P7 = 0: FOR O8 = 0 TO MX STEP 2
FOR P8 = 0 TO MY STEP 2
BLC(O7, P7) = A(O8, P8): A(O8, P8) = 0: O7 = O8 / 2: P7 = P8 / 2
NEXT: NEXT
FOR O7 = 0 TO MX: FOR P7 = 0 TO MY: A(O7, P7) = BLC(O7, P7): NEXT: NEXT
t = TIMER: DO: LOOP UNTIL TIMER > t + .2 OR DQBmouseLB = 0
REPUT
END SUB

SUB smooth
PAL 247, 0, 0, 1
LINE (0, 180)-(320, 190), 7, BF
FOR O = 1 TO MX - 1
FOR P = 1 TO MY - 1
RD = 0: BL = 0: GN = 0: FOR c% = -1 TO 1: FOR d% = -1 TO 1
e = A(O + c%, P + d%):
dqbgetcol e, rd1, gn1, bl1: RD = RD + rd1: BL = BL + bl1: GN = GN + gn1
NEXT: NEXT
LOCATE 1, 1
E2 = DQBfindCol(RD \ 9, GN \ 9, BL \ 9)
BLC(O, P) = E2
NEXT
LINE (0, 180)-((320 / MX) * O, 190), 4, BF
NEXT
FOR O = 1 TO MX - 1
FOR P = 1 TO MY - 1
A(O, P) = BLC(O, P)
NEXT: NEXT
REPUT
END SUB

SUB ssprite
GET (smx, smy)-(smx + MX, smy + MY), b(0)
'PLAY "mbL60O3AO2AO1A"
ff = 1
END SUB

SUB tmpbmp (filename$)
OPEN filename$ FOR BINARY AS #1
IF LOF(1) < 2 THEN PRINT "File does not exist": CLOSE : KILL filename$: SYSTEM
GET #1, 54, pnt
SCREEN 13
FOR SLOT% = 0 TO 255
 GET #1, , pnt
 b% = INT(ASC(pnt) / 4)
 GET #1, , pnt
 G% = INT(ASC(pnt) / 4)
 GET #1, , pnt
 R% = INT(ASC(pnt) / 4)
 PAL 0 + SLOT%, 0 + R%, 0 + b%, 0 + G%
 GET #1, , pnt
I$ = STRING$(320, " ")
NEXT SLOT%
FOR O = 1 TO 320
  GET #1, , I$
memcopy VARSEG(I$), VARPTR(I$), &HA000, 0, 320
NEXT
CLOSE
END SUB

