'FRAGGLE.BAS by Bill Buckels 1990
'Written in QuickBASIC Version 4.5
'produces and displays image fragments
'created from BASIC BSAVED MED RES CGA IMAGES
'Revised 2007 as a pure QuickBasic Program
'Removed PCX support because not written in QuickBasic
'Added resave back to BSaved Image
'Revised program structure for readability
'Increased error handling and added error messages
'Removed automatic naming from basename.
'Now using the .PUT extension when saving.
'Added 8 x 8 Block Based Fragments for C64 Style Saves
'Revised May 2008 to create silly things
DEFINT A-Z
'allocate memory for picture buffer
DIM PIC(8002) 'picture buffer
'constants for keypress values
NUL$ = CHR$(0)
UP$ = NUL$ + CHR$(72)
DN$ = NUL$ + CHR$(80)
LT$ = NUL$ + CHR$(75)
RT$ = NUL$ + CHR$(77)
ESC$ = CHR$(27)
ENTER$ = CHR$(13)
'constants for keypress status
FLAG = 0
ZERO = 0
ONE = 1
TWO = 2
DONE = 3
ABORT = 0
ERRORLEVEL = 0
ON ERROR GOTO ERRORHANDLE
SCREEN 1
DO
'bounds of the screen
X1 = 0: X2 = 319: Y1 = 0: Y2 = 199
GOSUB DRAWMENU 'Menu Routine
GOSUB GETCHOICE
IF ERRORLEVEL = 0 THEN
SELECT CASE PICTYPE%
CASE 1,5
'if we have been asked to fraggle
GOSUB VARFRAG
CASE 2
'if we're not fragging we're viewing so we stop and wait in that case
KEYPRESS$ = INPUT$(1)
CASE 3
'make a menu chip
GOSUB FIXEDFRAG
CASE 6
GOSUB SILLYFRAG
CASE 4 'bsave fragment
GOSUB RESAVE
END SELECT
END IF
ABORT = ZERO
ERRORLEVEL = 0
LOOP UNTIL PICNAME$ = "FINISHED"
END
DRAWMENU:
CLS
LINE (2,2)-(317,102),2,b
LINE (0,0)-(319,102),1,b
LOCATE 2,2
PRINT " FRAGGLE(C)
LOCATE 3,2
PRINT " Copyright Bill Buckels 1990-2007"
LOCATE 5,2
PRINT " 1) Fraggle a BSaved Image"
LOCATE 6,2
PRINT " 2) Load an Image Fragment"
LOCATE 7,2
PRINT " 3) Fraggle 88 x 52 from BSaved"
LOCATE 8, 2
PRINT " 4) BSave a Fraggled Image"
LOCATE 9, 2
PRINT " 5) Fraggle C64 Style from BSaved"
LOCATE 10,2
PRINT " 6) Fraggle Silly Things"
' menu explanations
LINE (2,104)-(317,197),1,b
LINE (0,104)-(319,199),2,b
LOCATE 15, 2
PRINT " Summary of Fraggle Hot Keys:"
LOCATE 17, 2
PRINT " R - Reverse Video"
LOCATE 18, 2
PRINT " L - Adjust Length By 1 pixel"
LOCATE 19, 2
PRINT " W - Adjust Width By 1 pixel"
LOCATE 20, 2
PRINT " ESC - Abandon Operation"
LOCATE 21, 2
PRINT " ENTER - 1st and 2nd corners"
LOCATE 22, 2
PRINT " Save Fragment"
LOCATE 23, 2
PRINT " ARROWS - Change Clip Position";
'get input
LOCATE 12,2
PRINT " Select from the above Menu options.";
RETURN
GETCHOICE:
'menu input subroutine
PICTYPE$ = INPUT$(1)
PICTYPE% = VAL(PICTYPE$)
SELECT CASE PICTYPE%
CASE 1, 3, 5, 6
CLS
PRINT "Raw Load"
FILES "*.BAS"
CASE 2, 4
CLS
PRINT "Image Fragment Load"
FILES "*.PUT"
CASE ELSE
END
END SELECT
LINE(0,180)- (319,195),0,BF
LINE(0,180)- (319,195),2,B
LINE(2,182)- (317,193),1,B
LOCATE 24,2
SELECT CASE PICTYPE%
CASE 1, 3, 5, 6
INPUT " PICTURE"; PICNAME$
CASE 2, 4
INPUT " FRAGMENT"; PICNAME$
END SELECT
IF PICNAME$ = "" THEN
PICTYPE%=0
ELSE
CLS
GOSUB LOADPIC
END IF
RETURN
LOADPIC:
' picture loader subroutine
SELECT CASE PICTYPE%
CASE 1, 3, 5, 6 'Raw Data
SEGMENT = &HB800 'Use Screen Segment
OFFSET = &H0
DEF SEG = SEGMENT
BLOAD PICNAME$, OFFSET 'Bload the Picture
CASE 2, 4
'load image fragments
SEGMENT = VARSEG(PIC(0))
OFFSET = VARPTR(PIC(0))
DEF SEG = SEGMENT
BLOAD PICNAME$, OFFSET
XTAB = INT((640 - PIC(0)) / 4) 'center horizontally
PUT (XTAB, 0), PIC, PSET 'put picture
END SELECT
DEF SEG 'Go back to original segment
IF ERRORLEVEL > 0 THEN
CLS
LINE (0,0)-(319,24),0,BF
LINE (0,0)-(319,24),1,B
LOCATE 2,2
PRINT PICNAME$ + " NOT loaded. Press a key..."
A$ = INPUT$(1)
END IF
RETURN
VARFRAG:
' subroutine for saving variable size image fragments
' backup the picture
GET (X1, Y1)-(X2, Y2), PIC
'and do an elastic box with a DOTTED line in two colors
LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
IF PICTYPE% = 5 THEN
INCR% = 8
ELSE
INCR% = 4
END IF
ENTER% = 1 'FRAG PART ONE- SET THE TOP LEFT CORNER
FLAG = 0
WHILE FLAG = 0
KEYPRESS$ = INKEY$
SELECT CASE KEYPRESS$
CASE "R", "r" 'reverse video
PUT (0,0),PIC,PRESET
GET (0,0)-(319,199), PIC
PUT (0,0),PIC,PSET
FLAG=ONE
CASE "L", "l" 'fine tuning
IF INCR% = 4 THEN
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT Y1 = 0 THEN
Y1 = Y1 - 1
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF Y2 > (Y1 + 4) THEN
Y2 = Y2 - 1
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
END IF
CASE "W", "w"
IF INCR% = 4 THEN
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT X1 = 0 THEN
X1 = X1 - 1
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF X2 > (X1 + 4) THEN
X2 = X2 - 1
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
END IF
CASE UP$ 'up arrow
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT Y1 = 0 THEN
Y1 = Y1 - INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF Y2 > (Y1 + INCR%) THEN
Y2 = Y2 - INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
CASE DN$ 'down arrow
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT Y1 > Y2 - INCR% THEN
Y1 = Y1 + INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF NOT Y2 = 199 THEN
Y2 = Y2 + INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
CASE LT$ 'left arrow
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT X1 = 0 THEN
X1 = X1 - INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF X2 > (X1 + INCR%) THEN
X2 = X2 - INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
CASE RT$ 'right arrow
IF ENTER% = 1 THEN ' TOP LEFT CORNER
IF NOT X1 > X2 - INCR% THEN
X1 = X1 + INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
ELSE ' BOTTOM RIGHT CORNER
IF NOT X2 = 319 THEN
X2 = X2 + INCR%
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
END IF
CASE ESC$
ABORT = TWO
FLAG = DONE
CASE ENTER$
ENTER% = ENTER% + 1 'FRAG PART TWO - SET THE BOTTOM RIGHT CORNER
IF ENTER% > 2 THEN FLAG = DONE
END SELECT
IF FLAG = ONE THEN
'change the position of the elastic box
'based on the last arrow or positional keypress
LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
FLAG = 0
END IF
WEND
IF ABORT = ZERO THEN
GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
END IF
RETURN
FIXEDFRAG:
' subroutine for saving 88 x 52 fixed size image fragments
' or 24 x 21 Double C4 Sprite
' backup the picture
GET (X1, Y1)-(X2, Y2), PIC
' use a printshop compatible image size
' 88 x 52
X1=0 : X2=87 : Y1 = 0 : Y2=51
'and do an elastic box with a DOTTED line
'in two colors to show-up regardless
LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
FLAG = 0
WHILE FLAG = 0
KEYPRESS$ = INKEY$
SELECT CASE KEYPRESS$
CASE "R", "r" 'reverse video
PUT (0,0),PIC,PRESET
GET (0,0)-(319,199), PIC
PUT (0,0),PIC,PSET
FLAG=ONE
CASE UP$
IF NOT Y1 = 0 THEN
Y1 = Y1 - 4
Y2 = Y2 - 4
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
CASE DN$ 'down arrow
IF NOT (Y2+4)>199 THEN
Y2 = Y2 + 4
Y1 = Y1 + 4
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
CASE LT$ 'left arrow
IF NOT X1 = 0 THEN
X1 = X1 - 4
X2 = X2 - 4
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
CASE RT$ 'right arrow
IF NOT (X2+4)>319 THEN
X1 = X1 + 4
X2 = X2 + 4
PUT (0, 0), PIC, PSET
FLAG = ONE
END IF
CASE ESC$
ABORT = TWO
FLAG = DONE
CASE ENTER$
FLAG = DONE
END SELECT
IF FLAG = ONE THEN
'change the position of the elastic box
'based on the last arrow or positional keypress
LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
FLAG = 0
END IF
WEND
IF ABORT = ZERO THEN
GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
END IF
RETURN
SILLYFRAG:
GET (X1, Y1)-(X2, Y2), PIC
X1=14 : X2=209: Y1 = 8 : Y2=71
SUFFIX$ = "1"
'and do an elastic box with a DOTTED line
'in two colors to show-up regardless
LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
FLAG = 0
WHILE FLAG = 0
KEYPRESS$ = INKEY$
SELECT CASE KEYPRESS$
CASE ESC$
ABORT = TWO
FLAG = DONE
CASE ENTER$
FLAG = DONE
END SELECT
WEND
IF ABORT = ZERO THEN
GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
GOSUB LOADPIC
GET (0, 0)-(319, 199), PIC
SUFFIX$ = "2"
Y1 = 72 : Y2=141
GOSUB SAVEFRAG
GOSUB LOADPIC
GET (0, 0)-(319, 199), PIC
SUFFIX$ = "3"
Y1 = 142: Y2=199
GOSUB SAVEFRAG
END IF
RETURN
SAVEFRAG:
'subroutine for saving an image fragment
'blot the screen one last time
'give the file name from the a .PUT extension
PUT (0, 0), PIC, PSET
GET (X1, Y1)-(X2, Y2), PIC
LINE (0,0)-(319,24),0,BF
LINE (0,0)-(319,24),1,B
LOCATE 2,2
IF PICTYPE% = 6 THEN
NEWPIC$ = PICNAME$
PRINT "FRAGMENT NAME"; NEWPIC$
ELSE
INPUT "FRAGMENT NAME"; NEWPIC$
IF NEWPIC$ = "" THEN RETURN
END IF
FRAG$ = NEWPIC$
NEWPIC$ = ""
A$ = ""
A% = 1
'parse until the period
WHILE NOT A$ = "."
IF A% < LEN(FRAG$)+1 THEN
A$ = MID$(FRAG$, A%, 1)
ELSE
A$ = "."
END IF
IF PICTYPE% = 6 AND A$ = "." THEN
NEWPIC$ = NEWPIC$ + SUFFIX$
END IF
NEWPIC$ = NEWPIC$ + A$
A% = A% + 1
WEND
NEWPIC$ = NEWPIC$ + "PUT"
'put the window into an array
'then point to the array
'and save it to disk
SEGMENT = VARSEG(PIC(0))
OFFSET = VARPTR(PIC(0))
DEF SEG = SEGMENT
'find the width and the height
'and calculate the length of the array
'raster lines break on byte boundaries
'the array header is two words in length
WIDE = INT((((X2 - X1) * 2) + 7) / 8)
HIGH = (Y2 - Y1)+1
PICSIZE = 4 + (WIDE * HIGH) +1
BSAVE NEWPIC$, OFFSET, PICSIZE
DEF SEG
CLS
LINE (0,0)-(319,24),0,BF
LINE (0,0)-(319,24),1,B
LOCATE 2,2
IF ERRORLEVEL = 0 THEN
PRINT NEWPIC$ + " saved. Press a key..."
ELSE
PRINT NEWPIC$ + " NOT saved. Press a key..."
END IF
A$ = INPUT$(1)
RETURN
RESAVE:
'subroutine for saving a Bsaved Image
'from an image fragment
GET (X1, Y1)-(X2, Y2), PIC
LINE (0,0)-(319,24),0,BF
LINE (0,0)-(319,24),1,B
LOCATE 2,2
INPUT "NEW NAME"; NEWPIC$
IF NEWPIC$ = "" THEN RETURN
FRAG$ = NEWPIC$
NEWPIC$ = ""
A$ = ""
A% = 1
'parse until the period
WHILE NOT A$ = "."
IF A% < LEN(FRAG$)+1 THEN
A$ = MID$(FRAG$, A%, 1)
ELSE
A$ = "."
END IF
NEWPIC$ = NEWPIC$ + A$
A% = A% + 1
WEND
NEWPIC$ = NEWPIC$ + "BAS"
'restore the screen
'and save it to disk
PUT (0, 0), PIC, PSET
SEGMENT = &HB800 'Use Screen Segment
OFFSET = &H0
DEF SEG = SEGMENT
PICSIZE = 16384
BSAVE NEWPIC$, OFFSET, PICSIZE
DEF SEG
CLS
LINE (0,0)-(319,24),0,BF
LINE (0,0)-(319,24),1,B
LOCATE 2,2
IF ERRORLEVEL = 0 THEN
PRINT NEWPIC$ + " saved. Press a key..."
ELSE
PRINT NEWPIC$ + " NOT saved. Press a key..."
END IF
A$ = INPUT$(1)
RETURN
ERRORHANDLE:
BEEP
ERRORLEVEL = 1
RESUME NEXT
|
