'=========================================================================== ' Subject: 3D WAVING FLAG Date: 08-02-97 (20:02) ' Author: Davey W. Taylor Code: QB, QBasic, PDS ' Origin: audio.squad@mailbox.swipnet.se Packet: GRAPHICS.ABC '=========================================================================== '旼컴컴컴컴컴컴컴컴컴컴컴--컴�--� -� � '� ** 3D WAVING FLAG ** '� Created by Davey W Taylor '� '� Please mention my name if you use this code in your program! '읕컴컴--컴�- � � ' ** If you have any comments / suggestions / questions, my email is: ** ' ** audio.squad@mailbox.swipnet.se ** '旼컴컴컴컴컴컴컴컴컴컴컴--컴�--� -� � '� ATTENTION! ATTENTION! ATTENTION! ATTENTION! ATTENTION! '� This program contains more than just 1 flag. Check '� the variables below! It can '� also be used to save the flag as a series of bitmap's '� to be used in an animation for example an animated '� GIF. You can also easily modify the program to display '� the flag at a higher resolution by modifying the vars. '� If you do this you should also implement reading from '� file. I will probably write a flag editor where you '� can also change the flag resolution! '읕컴컴--컴�- � � DECLARE SUB Fill (x.ul%, y.ul%, x.ur%, y.ur%, x.ll%, y.ll%, x.lr%, y.lr%, c%) DECLARE SUB GetPal (Attr%, Red%, Green%, Blue%) 'declare subs and funcs. DECLARE SUB SetPal (Attr%, Red%, Green%, Blue%) DECLARE FUNCTION GetCC$ () DECLARE FUNCTION SaveBMP! (f$, x%, y%, w%, h%, bpp%) '- theese variable should be changed! -- skip% = 0 'flag number (0 - 8) 'sweden (0) / usa (1) / ireland (2) 'iceland (3) / norway (4) / spain (5) 'denmark (6) / finland (7) / france (8) cnt$ = "sweden" 'name of flag files (max 7 chars) outdir$ = "c:\temp\flags\" 'where to save the files sav% = 0 '1 = save files, 0 = just animate on screen '------------------------------------- TYPE points ul AS INTEGER ur AS INTEGER ll AS INTEGER lr AS INTEGER c AS INTEGER END TYPE CONST pi2! = 6.283186 'pi * 2 CONST speed! = .6283186 'flag speed CONST movement! = 2.5 'movement amount CONST space% = 10 'space between pixels CONST startx% = 0 'start x coord. of flag CONST starty% = 0 'start y coort. of flag CONST xsize% = 22 'amount of horiz. pixels CONST ysize% = 12 'amount of vert. pixels CONST wavem! = .5 'waves multiplier CONST cinc% = 16 'color fix a CONST oinc% = 7 'color fix b DIM d!(1 TO xsize%, 1 TO ysize%) 'dimension vars DIM xc(1 TO (xsize% - 1) * (ysize% - 1)) AS points DIM yc(1 TO (xsize% - 1) * (ysize% - 1)) AS points DIM cr(1 TO (xsize% - 1) * (ysize% - 1)) AS INTEGER DIM flag(1 TO xsize% - 1, 1 TO ysize% - 1) AS INTEGER DIM buff(1 TO 23102) AS INTEGER RESTORE flags FOR n% = 1 TO (xsize - 1) * (ysize - 1) * skip% '(skip flag(s)) READ dummy% NEXT n% FOR y% = 1 TO (ysize - 1) 'read flag FOR x% = 1 TO (xsize - 1) READ flag(x%, y%) NEXT x% NEXT y% SCREEN 13 'gee... buff(1) = 1736 'initialize buffer buff(2) = 117 FOR o% = 1 TO 13 'set palette SetPal o%, 0 + oinc%, 0 + oinc%, o% + 15 + cinc% NEXT o% FOR o% = 14 TO 26 SetPal o%, 0 + oinc%, 0 + oinc%, (25 - o%) + 15 + cinc% NEXT o% FOR o% = 1 TO 13 SetPal o% + 25, o% + 15 + cinc%, o% + 15 + cinc%, 0 + oinc% NEXT o% FOR o% = 14 TO 26 SetPal o% + 25, (25 - o%) + 15 + cinc%, (25 - o%) + 15 + cinc%, 0 + oinc% NEXT o% FOR o% = 1 TO 13 SetPal o% + 50, o% + 15 + cinc%, 0 + oinc%, 0 + oinc% NEXT o% FOR o% = 14 TO 26 SetPal o% + 50, (25 - o%) + 15 + cinc%, 0 + oinc%, 0 + oinc% NEXT o% FOR o% = 1 TO 13 SetPal o% + 75, o% + 15 + cinc%, o% + 15 + cinc%, o% + 15 + cinc% NEXT o% FOR o% = 14 TO 26 SetPal o% + 75, (25 - o%) + 15 + cinc%, (25 - o%) + 15 + cinc%, (25 - o%) + 15 + cinc% NEXT o% FOR o% = 1 TO 13 SetPal o% + 100, 0 + oinc%, o% + 15 + cinc%, 0 + oinc% NEXT o% FOR o% = 14 TO 26 SetPal o% + 100, 0 + oinc%, (25 - o%) + 15 + cinc%, 0 + oinc% NEXT o% FOR x% = 1 TO xsize% 'calculate 3d pattern FOR y% = 1 TO ysize% d!(x%, y%) = (x% + y%) * wavem! DO WHILE d!(x%, y%) > pi2! d!(x%, y%) = d!(x%, y%) - pi2! LOOP NEXT y% NEXT x% DO FOR x% = 1 TO xsize% 'increase all points FOR y% = 1 TO ysize% d!(x%, y%) = d!(x%, y%) + speed! IF d!(x%, y%) > pi2! THEN d!(x%, y%) = d!(x%, y%) - pi2! NEXT y% NEXT x% p% = 0 'calculate positions and FOR x% = 1 TO xsize% - 1 'colors FOR y% = 1 TO ysize% - 1 p% = p% + 1 xc(p%).ul = ((x% + 0) * space%) + COS(d!(x% + 0, y% + 0)) * movement! + 1 yc(p%).ul = ((y% + 0) * space%) + SIN(d!(x% + 0, y% + 0)) * movement! + 1 xc(p%).ur = ((x% + 1) * space%) + COS(d!(x% + 1, y% + 0)) * movement! '- 1 yc(p%).ur = ((y% + 0) * space%) + SIN(d!(x% + 1, y% + 0)) * movement! + 1 xc(p%).ll = ((x% + 0) * space%) + COS(d!(x% + 0, y% + 1)) * movement! + 1 yc(p%).ll = ((y% + 1) * space%) + SIN(d!(x% + 0, y% + 1)) * movement! '- 1 xc(p%).lr = ((x% + 1) * space%) + COS(d!(x% + 1, y% + 1)) * movement! '- 1 yc(p%).lr = ((y% + 1) * space%) + SIN(d!(x% + 1, y% + 1)) * movement! '- 1 xc(p%).c = (xc(p%).ul + xc(p%).ur + xc(p%).ll + xc(p%).lr) / 4 yc(p%).c = (yc(p%).ul + yc(p%).ur + yc(p%).ll + yc(p%).lr) / 4 cr(p%) = INT(d!(x% + 0, y% + 0) * 4) + 1 IF cr(p%) > 25 THEN cr(p%) = 25 cr(p%) = cr(p%) + 25 * flag(x%, y%) NEXT y% NEXT x% p% = 0 FOR x% = 1 TO xsize% - 1 'draw it! FOR y% = 1 TO ysize% - 1 p% = p% + 1 LINE (xc(p%).ul, yc(p%).ul)-(xc(p%).ur, yc(p%).ur), cr(p%) LINE (xc(p%).ur, yc(p%).ur)-(xc(p%).lr, yc(p%).lr), cr(p%) LINE (xc(p%).lr, yc(p%).lr)-(xc(p%).ll, yc(p%).ll), cr(p%) LINE (xc(p%).ll, yc(p%).ll)-(xc(p%).ul, yc(p%).ul), cr(p%) PAINT (xc(p%).c, yc(p%).c), cr(p%), cr(p%) NEXT y% NEXT x% FOR x% = 1 TO xsize% - 1 'remove upper/lower edges p% = 1 + (11 * (x% - 1)) LINE (xc(p%).ul, yc(p%).ul - 1)-(xc(p%).ur, yc(p%).ur - 1), 0 LINE (xc(p%).ul, yc(p%).ul - 2)-(xc(p%).ur, yc(p%).ur - 2), 0 p% = p% + 10 LINE (xc(p%).lr, yc(p%).lr + 1)-(xc(p%).ll, yc(p%).ll + 1), 0 LINE (xc(p%).lr, yc(p%).lr + 2)-(xc(p%).ll, yc(p%).ll + 2), 0 NEXT x% FOR y% = 1 TO ysize% - 1 'remove left/right edges p% = y% LINE (xc(p%).ll - 1, yc(p%).ll)-(xc(p%).ul - 1, yc(p%).ul), 0 LINE (xc(p%).ll - 2, yc(p%).ll)-(xc(p%).ul - 2, yc(p%).ul), 0 p% = p% + 220 LINE (xc(p%).ur + 1, yc(p%).ur)-(xc(p%).lr + 1, yc(p%).lr), 0 LINE (xc(p%).ur + 2, yc(p%).ur)-(xc(p%).lr + 2, yc(p%).lr), 0 NEXT y% PSET (xc(231).lr + 1, yc(231).lr + 1), 0 'remove an ugly dot in 'lower right corner IF sav% = 1 THEN 'save or animate? in% = in% + 1 file$ = outdir$ + cnt$ + HEX$(in%) + ".bmp" IF sav% = 1 THEN r! = SaveBMP(file$, 7, 7, 217, 117, 8) IF r! THEN WIDTH 80, 25: PRINT "ERROR!": END END IF IF sav% = 1 THEN 'stop if saving? c! = c! + speed! IF c! > pi2! THEN END END IF LOOP WHILE INKEY$ = "" flags: sweden: DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0 usa: DATA 0,0,0,0,0,0,0,0,0,0,0,2,2,2,2,2,2,2,2,2,2 DATA 0,3,0,3,0,3,0,3,0,3,0,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,0,0,0,0,0,0,0,0,2,2,2,2,2,2,2,2,2,2 DATA 0,0,3,0,3,0,3,0,3,0,0,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,0,0,0,0,0,0,0,0,2,2,2,2,2,2,2,2,2,2 DATA 0,3,0,3,0,3,0,3,0,3,0,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,0,0,0,0,0,0,0,0,2,2,2,2,2,2,2,2,2,2 DATA 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 ireland: DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 DATA 4,4,4,4,4,4,4,3,3,3,3,3,3,3,1,1,1,1,1,1,1 iceland: DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 3,3,3,3,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 3,3,3,3,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0 norway: DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 3,3,3,3,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 3,3,3,3,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,3,0,0,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 spain: DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 denmark: DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 DATA 2,2,2,2,2,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 finland: DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 DATA 3,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3 france: DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 DATA 0,0,0,0,0,0,0,3,3,3,3,3,3,3,2,2,2,2,2,2,2 blank: DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 DEFINT A-Z SUB Fill (x.ul, y.ul, x.ur, y.ur, x.ll, y.ll, x.lr, y.lr, c%) uw% = x.ur - x.ul lw% = x.lr - x.ll uh% = y.ur - y.ul lh% = y.lr - y.ll l% = uw% IF l% < lw% THEN l% = lw% IF l% < ABS(uh%) THEN l% = ABS(uh%) IF l% < ABS(lh%) THEN l% = ABS(lh%) FOR n% = 1 TO l% ux% = x.ul + (uw% / l% * n%) uy% = y.ul + (uh% / l% * n%) lx% = x.ll + (lw% / l% * n%) ly% = y.ll + (lh% / l% * n%) ' th% = ly% - uy% ' tw% = lx% - ux% ' FOR tl% = 1 TO th% ' y% = tl% + uy% - 1 ' x% = ux% + tw% / th% * tl% ' PSET (x%, y%), c% ' PSET (x% + 1, y%), c% ' PSET (x%, y% + 1), c% ' PSET (x% + 1, y% + 1), c% ' NEXT tl% LINE (ux%, uy%)-(lx%, ly%), c% LINE (ux% + 1, uy%)-(lx% + 1, ly%), c% NEXT n% END SUB DEFSNG A-Z FUNCTION GetCC$ 'Reads palette and returns it as a 256 color rgb string cc$ = STRING$(768, 0) FOR p% = 1 TO 256 GetPal p% - 1, r%, g%, B% MID$(cc$, p% + (2 * (p% - 1)) + 0, 1) = CHR$(4 * (r% + 1) - 1) MID$(cc$, p% + (2 * (p% - 1)) + 1, 1) = CHR$(4 * (g% + 1) - 1) MID$(cc$, p% + (2 * (p% - 1)) + 2, 1) = CHR$(4 * (B% + 1) - 1) NEXT p% GetCC$ = cc$ END FUNCTION DEFINT A-Z SUB GetPal (Attr%, Red%, Green%, Blue%) 'SUB to get a color attribute OUT &H3C7, Attr% OUT &H3C8, Attr% Red% = INP(&H3C9) Green% = INP(&H3C9) Blue% = INP(&H3C9) END SUB DEFSNG A-Z FUNCTION SaveBMP (f$, x%, y%, w%, h%, bpp%) SELECT CASE bpp% '-------------- CASE 1: cs% = 2 'do needed calculations CASE 4: cs% = 16 ' CASE 8: cs% = 256 ' CASE 24: cs% = 0 ' CASE ELSE: SaveBMP = 5: CLOSE #1: EXIT FUNCTION ' END SELECT ' vl% = INT(8 / bpp%) ' IF bpp% = 24 THEN vl% = 1 ' IF INT(w% / 4) <> (w% / 4) THEN ' aa# = 4 * (INT(w% / 4) + 1) ' apl% = aa# - w% ' END IF ' IF bpp% = 24 THEN ' 'isize# = 0 'havn't figured out how to 'fsize# = isize# + 54 'calculate file size in ELSE '24 bit mode.... 'isize# = ((w% + apl%) * h%) / (8 / bpp%) 'and the other modes tend to 'fsize# = isize# + (cs% * 4) + 54 'cause an overflow... they END IF 'are not nescessary anyway offs% = (cs% * 4) + 54 '-------------- OPEN f$ FOR BINARY ACCESS WRITE AS #1 LEN = 1 'open file x$ = "BM" PUT #1, , x$ 'header x$ = MKL$(fsize#) PUT #1, , x$ 'filesize x$ = MKL$(0) PUT #1, , x$ 'reserved x$ = MKL$(offs%) PUT #1, , x$ 'offset to pict data x$ = MKL$(40) PUT #1, , x$ 'size of header x$ = MKL$(w%) PUT #1, , x$ 'width x$ = MKL$(h%) PUT #1, , x$ 'height x$ = MKI$(1) PUT #1, , x$ 'planes x$ = MKI$(bpp%) PUT #1, , x$ 'bits per pixel x$ = MKL$(0) PUT #1, , x$ 'compression x$ = MKL$(isize#) PUT #1, , x$ 'image size x$ = MKL$(2835) PUT #1, , x$ 'width in pels per metre x$ = MKL$(2835) PUT #1, , x$ 'height in ppm x$ = MKL$(0) PUT #1, , x$ 'used colors (who cares if it x$ = MKL$(0) ' says all???? ) PUT #1, , x$ 'important colors (i don't :) FOR p% = 1 TO cs% '-------------- GetPal p% - 1, r%, g%, B% 'Save palette ro$ = CHR$(((r% + 1) * 4) - 1) ' go$ = CHR$(((g% + 1) * 4) - 1) ' bo$ = CHR$(((B% + 1) * 4) - 1) ' o$ = bo$ + go$ + ro$ + CHR$(0) ' PUT #1, , o$ ' NEXT p% '-------------- IF bpp% = 24 THEN cad% = 255 ELSE cad% = cs% - 1 FOR yp% = y% + h% - 1 TO y% STEP -1 '-------------- got% = 0: c% = 0 'make a loop to save file t16% = 0 ' FOR xp% = x% TO x% + w% - 1 ' cr% = POINT(xp%, yp%) 'get POINT from screen PSET (xp%, yp%), cad% - cr% - 1 ' IF cr% < 0 THEN cr% = 0 ' IF cr% > 255 THEN cr% = 255 ' SELECT CASE bpp% ' CASE 1 'if b/w IF c% = 0 THEN v$ = CHR$(0) 'calculate the 8 bits p% = cr% MOD 2 ' a% = 2 ^ (7 - c%) ' IF p% THEN v$ = CHR$(ASC(v$) + a%) ' CASE 4 'if 16 c IF c% = 0 THEN t16% = 16 * (cr% MOD 16) 'calculate hi/low of byte IF c% = 1 THEN t16% = t16% + cr% MOD 16 ' v$ = CHR$(t16%) ' CASE 8 'if 256 c v$ = CHR$(cr%) 'use entire point CASE 24 ' GetPal cr%, r%, g%, B% 'check the palette o$ = CHR$(((r% + 1) * 4) - 1) + CHR$(((g% + 1) * 4) - 1) v$ = CHR$(((B% + 1) * 4) - 1) ' PUT #1, , o$ 'put the values directly got% = got% + 2 'to the file, leaving blue END SELECT 'for the loop PUT c% = (c% + 1) MOD vl% ' IF c% = 0 THEN PUT #1, , v$: got% = got% + 1 'PUT byte to file NEXT xp% ' IF c% <> 0 THEN PUT #1, , v$: got% = got% + 1 'if not done PUT bytes in x$ = CHR$(0) 'the file DO UNTIL INT(got% / 4) = (got% / 4) ' PUT #1, , x$ 'PUT the extra line-bytes got% = got% + 1 'to file LOOP ' NEXT yp% ' CLOSE #1 'close file END FUNCTION DEFINT A-Z SUB SetPal (Attr%, Red%, Green%, Blue%) 'SUB to set a color attribute OUT &H3C7, Attr% OUT &H3C8, Attr% OUT &H3C9, Red% OUT &H3C9, Green% OUT &H3C9, Blue% END SUB