Or is it something unique that Martin H Smith and James E Fisher made.
Here's the QBasic code. Too bad QBasic doesn't support unsigned integers and one byte integers.
Code: Select all
DECLARE FUNCTION toString$ (reg AS ANY)
DECLARE SUB rotateRight (reg AS ANY, i AS INTEGER)
DECLARE SUB shiftLeft (reg AS ANY, i AS INTEGER)
DECLARE FUNCTION toInteger% (reg AS ANY)
DECLARE SUB move (reg AS ANY, l AS LONG)
DECLARE SUB subtract (reg AS ANY, i AS INTEGER)
DEFSTR A-Z
'Use the following statement in the Immediate window for debugging
'PRINT "ax=" + toString$(ax) + ", bx=" + HEX$(bx) + ", cl=" + HEX$(cl) + ", dx=" + HEX$(dh) + " " + HEX$(dl) + ", si=" + HEX$(si) + ", di=" + HEX$(di) + ", bp=" + HEX$(bp)
OPEN "DRUGSPIC.LIN" FOR BINARY AS #1
OPEN "DRUGSPIC.LID" FOR BINARY AS #2
GET #1, 1, uncompressedSize%
TYPE register
lo AS STRING * 1
hi AS STRING * 1
END TYPE
DIM byte AS STRING * 1
DIM table(&H404 TO 16383) AS INTEGER 'Is 16383 large enough?
DIM si AS LONG
DIM siTemp AS LONG
DIM di AS LONG
DIM ax AS register
DIM bx AS INTEGER
DIM cl AS INTEGER '0 <= cl <= &HFF, but most of the time 0 <= cl <= 7
DIM dh AS INTEGER '1 <= dh <= &HFF
DIM dl AS INTEGER '9 <= dl <= &HFF
DIM reg AS register
DIM bp AS INTEGER
bx = &H404
cl = 1
dh = 1
dl = 9
bp = 1
'1 because QBasic is 1-based, 2 because of uncompressedSize%
GET #1, 0 + 1 + 2, byte
PUT #2, 0 + 1, byte
si = 1
di = 1
DO
GET #1, si + 1 + 2, ax
si = si + 2
GET #1, si + 1 + 2, byte
ax.lo = CHR$(ASC(ax.lo) XOR ASC(byte))
ax.lo = CHR$(ASC(ax.lo) AND ((&HFF * 2 ^ cl) AND &HFF))
ax.lo = CHR$(ASC(ax.lo) XOR ASC(byte))
rotateRight ax, cl
ax.hi = CHR$(ASC(ax.hi) AND dh)
cl = cl + dl
IF cl < &H10 THEN
si = si - 1
END IF
cl = cl AND 7
IF ASC(ax.hi) = 0 THEN
'{ax < &H100}
PUT #2, di + 1, ax.lo
di = di + 1
move ax, di
bp = bp + 1
subtract ax, bp
table(bx) = toInteger%(ax)
table(bx + 2) = bp
bp = 1
bx = bx + 4
ELSEIF (ASC(ax.hi) = 1) AND (ASC(ax.lo) = 0) THEN
'{ax = &H100}
GET #1, si + 1 + 2, ax
si = si + 2
rotateRight ax, cl
cl = cl + 2
IF cl < 8 THEN
si = si - 2
ELSE
si = si - 1
END IF
cl = cl AND 7
ax.lo = CHR$(ASC(ax.lo) AND 3)
IF ASC(ax.lo) <> 0 THEN
'{ax.lo <> 0}
ax.lo = CHR$(ASC(ax.lo) - 1)
IF ASC(ax.lo) <> 0 THEN
'{ax.lo <> 0}
'Done
IF HEX$(uncompressedSize%) <> HEX$(LOF(2)) THEN
PRINT "_decMth3: Decompressed to wrong size."
END IF
END
ELSE
'{ax.lo = 0}
GET #1, si + 1 + 2, ax
si = si + 2
GET #1, si + 1 + 2, byte
ax.lo = CHR$(ASC(ax.lo) XOR ASC(byte))
ax.lo = CHR$(ASC(ax.lo) AND ((&HFF * 2 ^ cl) AND &HFF))
ax.lo = CHR$(ASC(ax.lo) XOR ASC(byte))
rotateRight ax, cl
cl = cl + 9
IF cl < &H10 THEN
si = si - 1
END IF
cl = cl AND 7
PUT #2, di + 1, ax.lo
di = di + 1
bp = 1
bx = &H404
dh = 1
dl = 9
END IF
ELSE
'{ax.lo = 0}
dh = dh * 2 + 1
dl = dl + 1
END IF
ELSE
'{ax > &H100}
siTemp = si
move reg, di
subtract reg, bp
'{reg = di - bp}
bp = bp + 1
table(bx) = toInteger%(reg)
table(bx + 2) = bp
shiftLeft ax, 2
si = toInteger%(ax)
IF si < bx THEN
'{ax < bx}
bp = table(si + 2)
si = table(si)
ELSE
'{ax >= bx}
si = table(bx)
'{si = di - bp + 1}
END IF
'hack to make si an unsigned integer
IF si < 0 THEN
si = VAL("&H" + RIGHT$(HEX$(si), 4) + "&")
END IF
FOR i% = 1 TO bp
GET #2, si + 1, byte
PUT #2, di + 1, byte
si = si + 1
di = di + 1
NEXT i%
si = siTemp
bx = bx + 4
END IF
LOOP
SUB move (reg AS register, l AS LONG)
unsignedInt& = VAL("&H" + HEX$(l) + "&")
reg.hi = CHR$(unsignedInt& \ 256)
reg.lo = CHR$(unsignedInt& AND &HFF)
END SUB
SUB rotateRight (reg AS register, i AS INTEGER)
unsignedReg& = VAL("&H" + toString$(reg) + "&")
result& = unsignedReg&
FOR x% = 1 TO i
carry% = 0
IF result& AND 1 THEN
carry% = 1
END IF
result& = result& \ 2 + carry% * &H8000&
NEXT x%
reg.hi = CHR$(result& \ 256)
reg.lo = CHR$(result& AND &HFF)
END SUB
SUB shiftLeft (reg AS register, i AS INTEGER)
unsignedReg& = VAL("&H" + toString$(reg) + "&")
result& = unsignedReg& * (2 ^ i)
reg.hi = CHR$(result& \ 256)
reg.lo = CHR$(result& AND &HFF)
END SUB
SUB subtract (reg AS register, i AS INTEGER)
unsignedReg& = VAL("&H" + toString$(reg) + "&")
unsignedInt& = VAL("&H" + HEX$(i) + "&")
result& = unsignedReg& - unsignedInt&
reg.hi = CHR$(result& \ 256)
reg.lo = CHR$(result& AND &HFF)
END SUB
FUNCTION toInteger% (reg AS register)
toInteger% = VAL("&H" + toString$(reg))
END FUNCTION
FUNCTION toString$ (reg AS register)
hi$ = HEX$(ASC(reg.hi))
IF LEN(hi$) = 1 THEN hi$ = "0" + hi$
lo$ = HEX$(ASC(reg.lo))
IF LEN(lo$) = 1 THEN lo$ = "0" + lo$
toString$ = hi$ + lo$
END FUNCTION
