Ask Question

Name:
Title:
Your Question:

Answer Question

Name:
Your Answer:
User Submitted Source Code!


Description:
  1
Language: BASIC
Code:
'$DYNAMIC
DECLARE SUB fillTable (ATable() AS ANY)
DECLARE SUB viewPic (APicNumber AS INTEGER, AOffset AS LONG)
DECLARE SUB checkFile (AFilename AS STRING)
DECLARE FUNCTION fileExists% (AFilename AS STRING)


CONST FALSE = 0
CONST TRUE = NOT FALSE

TYPE tableType
  offset AS LONG
END TYPE

DIM SHARED ARCHIVEFILE AS STRING
'ARCHIVEFILE = "CELLB.001"
ARCHIVEFILE = COMMAND$

PRINT "Riedel Software Productions EGA picture viewer. Frenkel. 16-jul-2017."

checkFile ARCHIVEFILE

DIM offsets(0 TO 0) AS tableType

fillTable offsets()

i% = LBOUND(offsets)
viewPic i%, offsets(i%).offset

DIM k AS STRING
DO
  k = INKEY$
  IF k = CHR$(0) + "M" THEN             'Right
    IF i% < UBOUND(offsets) THEN
      i% = i% + 1
      viewPic i%, offsets(i%).offset
    END IF
  ELSEIF k = CHR$(0) + "K" THEN         'Left
    IF LBOUND(offsets) < i% THEN
      i% = i% - 1
      viewPic i%, offsets(i%).offset
    END IF
  ELSEIF k = CHR$(0) + "G" THEN         'Home
    IF i% <> LBOUND(offsets) THEN
      i% = LBOUND(offsets)
      viewPic i%, offsets(i%).offset
    END IF
  ELSEIF k = CHR$(0) + "O" THEN         'End
    IF i% <> UBOUND(offsets) THEN
      i% = UBOUND(offsets)
      viewPic i%, offsets(i%).offset
    END IF
  ELSEIF k = CHR$(27) THEN              'Escape
    END
  END IF
LOOP

REM $STATIC
SUB checkFile (AFilename AS STRING)

IF NOT fileExists(AFilename) THEN
  PRINT "File [" + AFilename + "] does not exist."
  PRINT "Press any key to continue . . . "
  DO WHILE INKEY$ = ""
  LOOP
  END
END IF

END SUB

FUNCTION fileExists% (AFilename AS STRING)

IF AFilename = "" THEN
  fileExists% = FALSE
ELSE

  DIM fileNumber AS INTEGER
  DIM fileSize   AS LONG

  fileNumber = FREEFILE
  OPEN AFilename FOR BINARY AS fileNumber
  fileSize = LOF(fileNumber)
  CLOSE fileNumber

  IF fileSize = 0 THEN
    KILL AFilename
    fileExists% = FALSE
  ELSE
    fileExists% = TRUE
  END IF
END IF

END FUNCTION

SUB fillTable (ATable() AS tableType)

DIM fileNumber AS INTEGER
DIM N          AS INTEGER 'number of files in archive

fileNumber = FREEFILE
OPEN ARCHIVEFILE FOR BINARY AS fileNumber

'Calculate number of files N
DIM o AS STRING * 3
GET fileNumber, 2, o
a% = ASC(MID$(o, 1, 1))
b% = ASC(MID$(o, 2, 1))
c% = ASC(MID$(o, 3, 1))
e& = c% * 256& * 256 + b% * 256& + a%
SEEK fileNumber, 8
N = 0
DO WHILE NOT (p& = e&)
  GET fileNumber, , o
  a% = ASC(MID$(o, 1, 1))
  b% = ASC(MID$(o, 2, 1))
  c% = ASC(MID$(o, 3, 1))
  p& = c% * 256& * 256 + b% * 256& + a%
  N = N + 1
LOOP
N = N - 1


REDIM ATable(0 TO N - 1) AS tableType


SEEK fileNumber, 8
FOR i% = 0 TO N - 1
  GET fileNumber, , o
  a% = ASC(MID$(o, 1, 1))
  b% = ASC(MID$(o, 2, 1))
  c% = ASC(MID$(o, 3, 1))
  ATable(i%).offset = c% * 256& * 256 + b% * 256& + a%
NEXT i%

CLOSE fileNumber

END SUB

SUB viewPic (APicNumber AS INTEGER, AOffset AS LONG)

DIM fileNumber AS INTEGER
DIM byte       AS STRING * 1

fileNumber = FREEFILE
OPEN ARCHIVEFILE FOR BINARY AS fileNumber

SEEK fileNumber, AOffset + 1
GET fileNumber, , check%
GET fileNumber, , wid%
GET fileNumber, , hei%
GET fileNumber, , transparency%

IF check% <> 3 THEN
  LOCATE 2, 1
  PRINT "check failed:"; check%
  PRINT APicNumber
ELSE

  SCREEN 7
  CLS
  x% = 0
  y% = 0
  useHighNibble% = TRUE
  lastColour% = -1
  DO WHILE y% <> hei%
    IF useHighNibble% THEN
      GET fileNumber, , byte
      colour% = ASC(byte) \ 16
    ELSE
      colour% = ASC(byte) AND 15
    END IF
    useHighNibble% = NOT useHighNibble%
   
    PSET (x%, y%), colour%
    x% = x% + 1
    IF x% = wid% THEN
      x% = 0
      y% = y% + 1
    END IF
   
    IF colour% = lastColour% THEN
      c% = &HFF
      count% = 0
     
      IF useHighNibble% THEN
        DO WHILE c% = &HFF
          GET fileNumber, , byte
          c% = ASC(byte)
          count% = count% + c%
        LOOP
      ELSE
        DO WHILE c% = &HFF
          c% = (ASC(byte) AND 15) * 16
          GET fileNumber, , byte
          c% = c% + (ASC(byte) \ 16)
          count% = count% + c%
        LOOP
      END IF
     
      FOR i% = 1 TO count%
        PSET (x%, y%), colour%
        x% = x% + 1
        IF x% = wid% THEN
          x% = 0
          y% = y% + 1
        END IF
      NEXT i%

      lastColour% = -1
    ELSE
      lastColour% = colour%
    END IF
  LOOP

END IF

CLOSE fileNumber

END SUB

Comments: