'===========================================================================
' Subject: RAW IMAGE LOADER & DITHER ALGO    Date: 05-10-00 (00:37)       
' Author:  Toshi Horie                       Code: QB                     
' Origin:  toshi.tekscode.com              Packet: GRAPHICS.ABC
'===========================================================================
'------------------------------------------------------------
' DITHER.BAS - fast RAW file loader and 16 color dither demo
' Copyright 2000 Toshihiro Horie
'------------------------------------------------------------
DECLARE SUB dither ()
DECLARE FUNCTION get13$ ()
DECLARE SUB setpal16 ()
DECLARE FUNCTION put13$ ()
DECLARE FUNCTION loadv% (filename$)
DECLARE SUB closev (handle%)
DECLARE SUB readv (handle%, array%())
DECLARE SUB loadraw2 (filename$)
DECLARE SUB precalc ()
DECLARE SUB setgrayscale ()
DECLARE SUB loadraw (filename$)
DEFINT A-Z
' manually define the type needed for INTERUPTX
' don't include qb.bi, it messes up the call absolute.
TYPE RegTypeX
	ax    AS INTEGER: bx   AS INTEGER: cx   AS INTEGER: dx   AS INTEGER
	bp    AS INTEGER: si   AS INTEGER: di   AS INTEGER: flags AS INTEGER
	ds    AS INTEGER: es   AS INTEGER
END TYPE
DECLARE SUB INTERRUPTX (intnum AS INTEGER, inreg AS RegTypeX, outreg AS RegTypeX)
DIM SHARED regs AS RegTypeX
DIM SHARED div3(767)
DIM SHARED ytab(199)
DIM SHARED div16(-105 TO 255)
DIM SHARED clip(-105 TO 371)
precalc


SCREEN 13: CLS
setgrayscale

'slow QB-only loader
'loadraw "amgpcd23.raw"
'SLEEP 2

' try the fast loader
CLS
loadraw2 "amgpcd23.raw"

'Floyd Steinberg dither
dither
SLEEP 2

END

SUB closev (handle%)
'close file with handle
    regs.ax = &H3E00
    regs.bx = handle%
    INTERRUPTX &H21, regs, regs

END SUB

SUB dither
' Floyd Steinberg dither algorithm
' implemented naively in QB by Toshi
' This version dithers 256 level grayscale to 16 colors
DIM vscreen%(32000)
DIM scanline2(319, 99)
getcpy$ = get13$
'putcpy$ = put13$


DEF SEG = VARSEG(getcpy$)
CALL ABSOLUTE(vscreen%(), SADD(getcpy$))
DEF SEG = VARSEG(vscreen%(0))
SLEEP 2
CLS

'DEF SEG = &HA000
setpal16
LOCATE 20, 1: COLOR 15: PRINT "Lowering color depth"
p = 0
FOR y = 0 TO 99
FOR x = 0 TO 319
    'scanline2(x, y) = POINT(x, y)
    scanline2(x, y) = PEEK(p)
    PSET (x, y), div16(scanline2(x, y))
    p = p + 1
NEXT
NEXT
ERASE vscreen%
SLEEP 3
LOCATE 20, 1: COLOR 15: PRINT "Dithering to 16 colors"
DEF SEG = &HA000
FOR y = 1 TO 98
FOR x = 1 TO 318
    trueintensity = scanline2(x, y)
    approx = trueintensity AND 240
    POKE (ytab(y) + x), div16%(approx)
   
    'calculate error term,  -15<=errterm<=15
    errterm = trueintensity - approx

' spread 7/16 of the error into the pixel to the right, at (x+1,y)
    scanline2(x + 1, y) = clip(scanline2(x + 1, y) + div16(errterm * 7))

' spread 3/16 of the error into the pixel below and to the left
    scanline2(x - 1, y + 1) = clip(scanline2(x - 1, y + 1) + div16(errterm * 3))

' spread 5/16 of the error into the pixel below
    e5 = div16(errterm * 5)
    scanline2(x, y + 1) = clip(scanline2(x, y + 1) + e5)

' spread 5/16 of the error into the pixel below and to the right
    scanline2(x + 1, y + 1) = clip(scanline2(x + 1, y + 1) + e5)
NEXT
NEXT

LOCATE 20, 1: COLOR 15: PRINT "Dithering successful!       "
'DEF SEG = VARSEG(putcpy$)
'CALL ABSOLUTE(vscreen%(), SADD(putcpy$))
'ERASE vscreen%
END SUB

DEFSNG B-Z
DEFSTR A
FUNCTION get13$
'-------------------------------------------------------------------
' GETSCREEN13 function by Rick Elbers
'This function gets a screen 13 to an QBASIC array. 386 + routine
'STACKPASSING: ARRAY%()
'IN          : SCREEN 13 EMPTY
'OUT         : ARRAY%() FILLED
'-------------------------------------------------------------------
'SET UP STACKFRAME
ASM = ASM + CHR$(&H55)                              'PUSH BP
ASM = ASM + CHR$(&H89) + CHR$(&HE5)                 'MOV BP,SP
ASM = ASM + CHR$(&H1E)                              'PUSH DS
ASM = ASM + CHR$(&H6)                               'PUSH ES
'GET POINTER TO ARRAY FROM STACK
ASM = ASM + CHR$(&H8B) + CHR$(&H5E) + CHR$(&H6)     'MOV BX,[BP+06]>ARRAY()
'SET UP CX TO 64000/4, ES[DI] TO ARRAY, DS[SI] TO A000:0
ASM = ASM + CHR$(&HB9) + CHR$(&H80) + CHR$(&H3E)    'MOV CX,3E80h
ASM = ASM + CHR$(&HC4) + CHR$(&H3F)                 'LES DI,[BX] ARRAY()
ASM = ASM + CHR$(&H31) + CHR$(&HF6)                 'XOR SI,SI
ASM = ASM + CHR$(&HB8) + MKI$(&HA000)               'MOV AX,A000
ASM = ASM + CHR$(&H8E) + CHR$(&HD8)                 'MOV DS,AX SCREENSEG
'COPY IT USING THE BLAZE OF MOVSD
ASM = ASM + CHR$(&HF3) + CHR$(&H66) + CHR$(&HA5)    'REP MOVSD < 386
'WE ARE DONE :RETURN TO QBASIC
ASM = ASM + CHR$(&H7)                               'POP ES
ASM = ASM + CHR$(&H1F)                              'POP DS
ASM = ASM + CHR$(&H5D)                              'POP BP
ASM = ASM + CHR$(&HCA) + MKI$(2)                    'RETF 2
get13$ = ASM
END FUNCTION

DEFSNG A
SUB loadraw (filename$)
'loads a 320 x (maxy+1) 16-bit color RGB-encoded .RAW file
' and displays in in grayscale
ff% = FREEFILE
OPEN filename$ FOR BINARY AS #ff%
IF LOF(1) = 0 THEN
    SCREEN 0: WIDTH 80: CLS
    PRINT "**"; filename$; " doesn't exist.**"
    CLOSE : KILL filename$: END
END IF

buffer$ = STRING$(320 * 3, 64)
DEF SEG = &HA000
z% = 0
FOR j% = 0 TO 99
 GET #ff%, , buffer$
 IF EOF(ff%) THEN END
 FOR s% = 1 TO 959 STEP 3
  r% = div3%(ASC(MID$(buffer$, s%, 1)))
  g% = div3%(ASC(MID$(buffer$, s% + 1, 1)))
  b% = div3%(ASC(MID$(buffer$, s% + 2, 1)))
  POKE z%, r% + g% + b%
  z% = z% + 1
 NEXT
NEXT j%
DEF SEG = &HA000 + 2000 'segment changes 20/scanline * 100 scanlines
z% = 0
FOR j% = 0 TO 99
 GET #ff%, , buffer$
 IF EOF(ff%) THEN END
 FOR s% = 1 TO 959 STEP 3
  r% = div3%(ASC(MID$(buffer$, s%, 1)))
  g% = div3%(ASC(MID$(buffer$, s% + 1, 1)))
  b% = div3%(ASC(MID$(buffer$, s% + 2, 1)))
  POKE z%, r% + g% + b%
  z% = z% + 1
 NEXT
NEXT j%
CLOSE #ff%
END SUB

DEFINT A-Z
SUB loadraw2 (filename$)
'RAW file fast loader
'uses a 65280 byte buffer
'displays it in grayscale

DIM vscreen%(32640) '65280 bytes -> 21760 pixels -> 68 lines
putcpy$ = put13$
MID$(putcpy$, 10, 2) = MKI$(&H1540) '=(68)*320\4


'-----------------block 1----------------------
handle% = loadv(filename$)

CALL readv(handle%, vscreen%())

z% = 0
s% = 0
DEF SEG = VARSEG(vscreen%(0))
WHILE s% < 32766
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND

r% = div3%(PEEK(32766))
g% = div3%(PEEK(32767))
b% = div3%(PEEK(-32768))
POKE z%, r% + g% + b%

z% = z% + 1
s% = -32767
WHILE s% < -256
  'slower way (uses smaller LUT)
  ' r% = div3%(PEEK(s%))
  ' g% = div3%(PEEK(s% + 1))
  ' b% = div3%(PEEK(s% + 2))
  ' POKE z%, r% + g% + b%
  'faster way
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND
DEF SEG = VARSEG(putcpy$)
CALL ABSOLUTE(vscreen%(), SADD(putcpy$))


'-----------------block 2----------------------
CALL readv(handle%, vscreen%())

z% = 0
s% = 0
DEF SEG = VARSEG(vscreen%(0))
WHILE s% < 32766
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND

  
 
POKE z%, div3%((PEEK(32766)) + (PEEK(32767)) + (PEEK(-32768)))

z% = z% + 1
s% = -32767
WHILE s% < -256
  'covert 16-bit pixel to 8-bit greyscale
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND



MID$(putcpy$, 15, 2) = MKI$(&HA000 + 20 * 68)
DEF SEG = VARSEG(putcpy$)
CALL ABSOLUTE(vscreen%(), SADD(putcpy$))

'-----------------block 3----------------------
CALL readv(handle%, vscreen%())

z% = 0
s% = 0
DEF SEG = VARSEG(vscreen%(0))
WHILE s% < 32766
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND

r% = div3%(PEEK(32766))
g% = div3%(PEEK(32767))
b% = div3%(PEEK(-32768))
POKE z%, r% + g% + b%

z% = z% + 1
s% = -32767
mm% = -256 - 5 * 320 * 3
WHILE s% < mm%
  POKE z%, div3%(PEEK(s%) + PEEK(s% + 1) + PEEK(s% + 1))
  s% = s% + 3
  z% = z% + 1
WEND

'modify our asm code so it blits the remaining part of the buffer
MID$(putcpy$, 10, 2) = MKI$(&H13B0) '=(68-5)*320\4
MID$(putcpy$, 15, 2) = MKI$(&HA000 + 20 * 68 * 2)
DEF SEG = VARSEG(putcpy$)
CALL ABSOLUTE(vscreen%(), SADD(putcpy$))


CALL closev(handle%)
'SCREEN 0: WIDTH 80, 50
'FOR i = 1 TO 28
'PRINT i; HEX$(ASC(MID$(putcpy$, i, 1)))
'NEXT
ERASE vscreen%
END SUB

FUNCTION loadv (filename$)
f$ = filename$ + CHR$(0) 'convert to ASCIIZ

'open file
regs.ax = &H3D00
regs.ds = VARSEG(f$)  ' segment of filename
regs.dx = SADD(f$)    ' offset of filename
INTERRUPTX &H21, regs, regs  ' DOS syscall
handle% = regs.ax            ' save filehandle
IF regs.flags AND 1 THEN
    SELECT CASE handle%
	   CASE 1
		 PRINT "Invalid function."
	   CASE 2
		 PRINT "File not found."
	   CASE 3
		  PRINT "Path not found."
	   CASE 4
		  PRINT "No handles available."
	   CASE 5
		  PRINT "Access denied."
	   CASE &HC
		  PRINT "Invalid access code."
    END SELECT
    END
END IF
loadv% = handle%


END FUNCTION

SUB precalc
FOR i = 0 TO 767
    div3(i) = i \ 3
NEXT i
FOR i = -105 TO 255
    div16(i) = i \ 16
NEXT i
FOR i = 0 TO 99
    ytab(i) = i * 320
NEXT i

FOR i = -105 TO 371
    IF i < 0 THEN
	   clip(i) = 0
    ELSEIF i > 255 THEN
	   clip(i) = 255
    ELSE clip(i) = i
    END IF
NEXT i
END SUB

DEFSNG B-Z
DEFSTR A
FUNCTION put13$
' by rick elbers
'-------------------------------------------------------------------
'This function puts a QB array to screen 13. 386 + routine
'STACKPASSING: ARRAY()
'IN          : ARRAY() FILLED
'OUT         : SCREEN 13 FILLED
'-------------------------------------------------------------------
'SET UP STACKFRAME
ASM = ASM + CHR$(&H55)                              'PUSH BP
ASM = ASM + CHR$(&H89) + CHR$(&HE5)                 'MOV BP,SP
ASM = ASM + CHR$(&H1E)                              'PUSH DS
ASM = ASM + CHR$(&H6)                               'PUSH ES
'GET POINTER TO ARRAY FROM STACK
ASM = ASM + CHR$(&H8B) + CHR$(&H5E) + CHR$(&H6)     'MOV BX,[BP+06]>ARRAY()
'SET UP CX TO 64000/4, ES[DI] TO ARRAY, DS[SI] TO A000:0
ASM = ASM + CHR$(&HB9) + CHR$(&H80) + CHR$(&H3E)    'MOV CX,3E80h
ASM = ASM + CHR$(&H31) + CHR$(&HFF)                 'XOR DI,DI
ASM = ASM + CHR$(&HB8) + MKI$(&HA000)               'MOV AX,A000
ASM = ASM + CHR$(&H8E) + CHR$(&HC0)                 'MOV ES,AX SCREENSEG
ASM = ASM + CHR$(&HC5) + CHR$(&H37)                 'LDS SI,[BX] ARRAY()
'COPY IT USING THE BLAZE OF MOVSD
ASM = ASM + CHR$(&HF3) + CHR$(&H66) + CHR$(&HA5)    'REP MOVSD < 386
'WE ARE DONE :RETURN TO QBASIC
ASM = ASM + CHR$(&H7)                               'POP ES
ASM = ASM + CHR$(&H1F)                              'POP DS
ASM = ASM + CHR$(&H5D)                              'POP BP
ASM = ASM + CHR$(&HCA) + MKI$(2)                    'RETF 2
put13$ = ASM
END FUNCTION

DEFINT A-Z
SUB readv (handle%, array%())
'Read and display the file (vertically interlaced)
    regs.ax = &H3F00
    regs.bx = handle%
    regs.cx = -256   ' number of bytes to copy = 65280 (68 complete scanlines)
    regs.ds = VARSEG(array%(0))  ' dest=screen 13's segment
    regs.dx = VARPTR(array%(0))       '      at offset 0
    INTERRUPTX &H21, regs, regs
 

END SUB

SUB setgrayscale
OUT &H3C8, 0
FOR i% = 0 TO 255
 OUT &H3C9, i% \ 4
 OUT &H3C9, i% \ 4
 OUT &H3C9, i% \ 4
NEXT i%

END SUB

SUB setpal16
FOR i% = 0 TO 15
    OUT &H3C8, i%
 OUT &H3C9, i% * 4
 OUT &H3C9, i% * 4
 OUT &H3C9, i% * 4
NEXT i%
'red to show wrong parts of palette are being used
FOR i% = 16 TO 255
    OUT &H3C8, i%
 OUT &H3C9, 255
 OUT &H3C9, 0
 OUT &H3C9, 0
NEXT i%
END SUB