'===========================================================================
' Subject: BITMAP ZOOMING ALGORITHM          Date: 04-04-97 (18:54)       
' Author:  Angelo Ken Pesce                  Code: QB, QBasic, PDS        
' Origin:  us0082@uniserv.uniplan.it       Packet: GRAPHICS.ABC
'===========================================================================
DECLARE SUB baa (xdim%, ydim%, xend%, yend%, xerr%, yerr%)
DECLARE SUB bmpset ()
DECLARE SUB bzoom (xdim%, ydim%, xend%, yend%)
DECLARE SUB display (xend%, yend%)

' --------------------------------------------
' USE QB /AH or QBX /AH (only for big zooms) I
' $DYNAMIC  -- only with quickbasic          I
' --------------------------------------------

' Bitmap zooming algorithm test
' By Angelo KEN Pesce 1997

' Set up the screen mode and other things --------
SCREEN 13
DEFINT A-Z
FOR i = 0 TO 63: PALETTE i, i * 256: NEXT

' Set up the suorce bitmap -----------------------
CONST xdim = 50, ydim = 50
DIM SHARED org(xdim, ydim) AS INTEGER
CALL bmpset: ' does a simple circle pattern
CLS

' Input zooming parametrers ----------------------
COLOR 63: ' bright red
PRINT "Bitmap Zoom  v1.6"
PRINT "-------------------"
PRINT "Current features:"
PRINT ") Zoom in and out"
PRINT ") All integers processing"
PRINT ") Jittered Antialiasing"
PRINT ") Bitmap streching"
PRINT ") Little anim :-)"
PRINT
PRINT "Org. X Size"; xdim
PRINT "Org. Y Size"; ydim
PRINT
INPUT "Dest. X Size"; xend
INPUT "Dest. Y Size"; yend
PRINT
INPUT "Antialiasing value (2=normal,8=best)"; aa
INPUT "Jitter value (25=normal)"; jt
CLS

' DIMension destination arrays -------------------
DIM SHARED dest(xend, yend)

' DoZoom -----------------------------------------
CALL bzoom(xdim, ydim, xend, yend)

' AntiAlias --------------------------------------
' antialias is done by shifting xerr and yerr
FOR i = 0 TO aa
CALL baa(xdim, ydim, xend, yend, jt * RND - (jt / 2), jt * RND - (jt / 2))
NEXT

' Display result ---------------------------------
CALL display(xend, yend)


' Anim Demo --------------------------------------
DO: LOOP WHILE INKEY$ = ""
CLS
PRINT "ANIM DEMO"
DO: LOOP WHILE INKEY$ = ""
CLS
REDIM dest(80, 80)
DO
FOR x = 10 TO 80
CALL bzoom(xdim, ydim, x, x)
CALL display(x, x)
a$ = a$ + INKEY$
NEXT
FOR x = 80 TO 10 STEP -1
CALL bzoom(xdim, ydim, x, x)
CALL display(x, x)
a$ = a$ + INKEY$
NEXT
LOOP UNTIL a$ <> ""

REM $STATIC
SUB baa (xdim, ydim, xend, yend, xerr, yerr)
xratio = INT((xdim * 100) / xend)
yratio = INT((ydim * 100) / yend)

DO
xerr = xerr + xratio
3 IF xerr >= 100 THEN xo = xo + 1: xerr = xerr - 100: GOTO 3
IF xo >= xdim THEN GOSUB ycheck1
IF ys > yend OR yo > ydim THEN EXIT SUB
IF xs > xend THEN xs = xend

' ANTIALIASING ROUTINE ------------
dest(xs, ys) = (org(xo, yo) + dest(xs, ys)) / 2
' ---------------------------------

xs = xs + 1
LOOP
ycheck1:
xerr = 0: xo = 0: xs = 0: ys = ys + 1
yerr = yerr + yratio
4 IF yerr >= 100 THEN yo = yo + 1: yerr = yerr - 100: GOTO 4
RETURN

END SUB

SUB bmpset

' Set pattern
FOR i = 0 TO 63 STEP 3
CIRCLE (xdim / 2, ydim / 2), i, 63 - i
NEXT

' Read pattern
DO: LOOP WHILE INKEY$ = ""
FOR x = 0 TO xdim
FOR y = 0 TO ydim
org(x, y) = POINT(x, y)
PSET (x, y), 63
NEXT
NEXT
DO: LOOP WHILE INKEY$ = ""
END SUB

SUB bzoom (xdim, ydim, xend, yend)

' Set up x/y zoom ratio
xratio = INT((xdim * 100) / xend)
yratio = INT((ydim * 100) / yend)

DO
' check for x error
xerr = xerr + xratio
1 IF xerr >= 100 THEN xo = xo + 1: xerr = xerr - 100: GOTO 1

' if XO = XDIM then update YO and YS
IF xo >= xdim THEN GOSUB ycheck

' Some bound checks
IF ys > yend OR yo > ydim THEN EXIT SUB
IF xs > xend THEN xs = xend

dest(xs, ys) = org(xo, yo)

xs = xs + 1: ' Move xs (screen x) one pixel away
LOOP

'-------------------------------------------------- SUBS
ycheck:
' When XO=XDIM update YO and YS

' start a new line
xerr = 0: xo = 0: xs = 0: ys = ys + 1

' Check for y error
yerr = yerr + yratio
2 IF yerr >= 100 THEN yo = yo + 1: yerr = yerr - 100: GOTO 2
RETURN
END SUB

SUB display (xend, yend)
FOR x = 0 TO xend
FOR y = 0 TO yend
PSET (x, y), dest(x, y)
NEXT
NEXT
END SUB