Portrait was made with Portait_bas included in the zip file. Image by Cristian from an official portait of QE II.
Between them these routines can fill a regular or irregular shape with a colour, texture, or even an image.
Portrait was made with Portait_bas included in the zip file. Image by Cristian from an official portait of QE II.
Let's start with the simplest one, which is great for filling in a small shape with a single colour without taking up a lot of code space, and end up with an all-singing, all-dancing version.
These routines, as they stand, are all for GD2 (high colour) systems only, although the algorithms should work just as well for traditional QL colour systems given some different toolkit commands and a little elbow grease. I have only gone to the trouble of making the final routine compatible with all GD2 modes. The others will only work in 16 bit modes without some changes.
For a discussion of the matter and to see how this all came about see this topic on QL Forum.
The first Flood Fill routine that turned up was this little number from Tomas (tcat). It was written in Pascal (see the remarks at the end of the code for the original code) and translated to SBASIC by me.
FILLS fills a shape with a single colour. It runs as intended in mode 32, but may possibly work in mode 33 without change too. It could be made to work in any QL mode with a different function to read the pixels. RPIX% is for GD2 only.
100 rem + ------------------------------------------------------------------------ + 102 rem |< Fills >| 104 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 106 rem | An early, recursive, attempt by tcat | 108 rem | | 110 rem | Written in Pascal and translated to SBASIC by pjw. For details see: | 112 rem | https://qlforum.co.uk/viewtopic.php?f=3&t=2817&start=40#p28465 | 114 rem | | 116 rem | While it looks nice, simple and logical, it spends a lot of time | 118 rem | backtracking and eats a lot of memory. Great for small, simple shapes | 120 rem | in a compact routine. | 122 rem | | 124 rem | I havent spent much time adapting, "universalising" or error trapping | 126 rem | this code. This is left as an excercise for anyone who needs it! | 128 rem | | 130 rem | Dependency: RPIX% | 132 rem + ------------------------------------------------------------------------ + 134 rem | V0.00, tcat, 2019 Jun 21 | 136 rem | V0.00, pjw, 2019 Jun 29, translated and adapted | 138 rem + ------------------------------------------------------------------------ + 140 : 142 DEFine PROCedure Fills(chn, tgc%, rpc%, x%, y%) 144 rem tgc%, rpc% - target, replacement colour 146 : 148 rem PAUSE 1: rem remove to see the action 150 IF tgc% = RPIX%(#chn; x%, y%) THEN 152 rem RPIX% = pick colour at x,y coord 154 BLOCK#chn; 1, 1, x%, y%, rpc% : rem no clip 156 Fills#chn; tgc%, rpc%, x%, y% - 1 : rem south 158 Fills#chn; tgc%, rpc%, x%, y% + 1 : rem north 160 Fills#chn; tgc%, rpc%, x% - 1, y% : rem west 162 Fills#chn; tgc%, rpc%, x% + 1, y% : rem east 164 END IF 166 END DEFine Fills 168 : 170 : 172 rem PROCEDURE Fill*(tgc, rpc, x, y: INTEGER); 174 rem VAR c: INTEGER; (*tgc, rpc - target, replacement colour*) 176 rem BEGIN 178 rem (*c = pick colour at x,y coord *) 180 rem IF c = tgc THEN 182 rem Display.Dot(rpc, x, y, Display.replace); (*no clip*) 184 rem Fill(tgc, rpc, x, y-1); (*south*) 186 rem Fill(tgc, rpc, x, y+1); (*north*) 188 rem Fill(tgc, rpc, x-1, y); (*west*) 190 rem Fill(tgc, rpc, x+1, y); (*east*) 192 rem END 194 rem END Fill;
To test it LRESPR the included toolkit, FFILL_bin, and LRUN
The next one up is from Tobias (tofro):
100 rem + ------------------------------------------------------------------------ + 102 rem |< FloodFill V0 >| 104 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 106 rem | This is the original FloodFill by Tobias Fröschle | 108 rem | | 110 rem | See https://qlforum.co.uk/viewtopic.php?f=3&t=2817&p=28590#p28593 | 112 rem | | 114 rem | Ive tweaked it slightly: integer variables and stack, added LOCals, | 116 rem | replaced SCR_XLIM/YLIM with WINDSZ, etc. Any errors are mine. | 118 rem | | 120 rem | Dependencies: RPIX%, WINDSZ from Knoware.no/toolkits or just use the | 122 rem | included FFILL_bin. Other toolkits may provide the same. WINDSZ can be | 124 rem | replaced by adding the known window metrics, eg scrlx% = 256: scrly% | 126 rem | = 202 | 128 rem | | 130 rem | LRUN in standard SBASIC console | 132 rem + ------------------------------------------------------------------------ + 134 rem | V0.00, tofro, 2019 Jun 30 | 136 rem | V0.01, pjw, 2022 Oct 30 | 138 rem + ------------------------------------------------------------------------ + 140 : 142 rem The scanline floodfill algorithm using a stack 144 DEFine PROCedure FloodFill (channel, oldColor%, newColor%, x, y) 146 LOCal stackLoop, leftLoop, rightLoop 148 LOCal spanAbove, spanBelow, stack% (128), stackCtr% 150 LOCal x%, y%, scrlx%, scrly% 152 : 154 IF oldColor% = newColor% THEN 156 rem Nothing to do 158 RETurn 160 END IF 162 WINDSZ#channel; scrlx%! scrly%, x%, y% 164 x% = x: y% = y 166 stackCtr% = 0 168 stack% (stackCtr%) = x% : stackCtr% = stackCtr% + 1 : stack% (stackCtr%) = y% : stackCtr% = >> stackCtr% + 1 170 rem PRINT#0,"Push:", x%, y%, stackCtr% 172 rem PAUSE #0,-1 174 rem Loop until stack empty 176 REPeat stackLoop 178 IF stackCtr% <= 0 THEN 180 EXIT stackLoop 182 END IF 184 stackCtr% = stackCtr% - 1 : y% = stack% (stackCtr%) : stackCtr% = stackCtr% - 1 : x% = >> stack% (stackCtr%) 186 rem PRINT #0; "Pop:", x%, y%, stackCtr% 188 rem PAUSE #0, -1 190 : 192 rem search left boundary 194 REPeat leftLoop 196 IF x% < 0 : EXIT leftLoop 198 IF RPIX% (#channel; x%, y%) <> oldColor% THEN 200 EXIT leftLoop 202 ELSE 204 x% = x% - 1 206 END IF 208 END REPeat leftLoop 210 x% = x% + 1 212 spanAbove = 0 214 spanBelow = 0 216 rem search right boundary 218 REPeat rightLoop 220 IF x% >= scrlx% : EXIT rightLoop 222 IF RPIX% (#channel; x%, y%) <> oldColor% THEN 224 EXIT rightLoop 226 END IF 228 BLOCK #channel, 1, 1, x%, y%, newColor% 230 rem look into scanline above 232 IF y% > 0 THEN 234 IF spanAbove = 0 THEN 236 IF RPIX% (#channel; x%, y% - 1) = oldColor% THEN 238 stack% (stackCtr%) = x% :stackCtr% = stackCtr% + 1 : stack% (stackCtr%) = y% - 1 : >> stackCtr% = stackCtr% + 1 240 rem PRINT#0,"Push:", x%, y% - 1, stackCtr% 242 spanAbove = 1 244 END IF 246 ELSE 248 IF RPIX%(#channel; x%, y% - 1) <> oldColor% THEN 250 spanAbove = 0 252 END IF 254 END IF 256 END IF 258 IF y% < (scrly% - 1) THEN 260 IF spanBelow = 0 THEN 262 IF RPIX%(#channel; x%, y% + 1) = oldColor% THEN 264 stack% (stackCtr%) = x% :stackCtr% = stackCtr% + 1 : stack% (stackCtr%) = y% + 1 : >> stackCtr% = stackCtr% + 1 266 rem PRINT #0, "Push: ", x%, y% + 1, stackCtr% 268 spanBelow = 1 270 END IF 272 ELSE 274 IF RPIX% (#channel; x%, y% + 1) <> oldColor% THEN 276 spanBelow = 0 278 END IF 280 END IF 282 END IF 284 x% = x% + 1 286 END REPeat rightLoop 288 END REPeat stackLoop 290 END DEFine FloodFill
Load the toolkit as above and LRUN the demo program FloodFill_bas to test it.
This routine fills any enclosed shape with a single colour. See the code blurb for details. It runs in all GD2 system in 16-bit modes 32 and 33. But note that the colour codes are all in NATIVE format, so the same number normally represent different colours in mode 32 and 33.
One way to get the native colour you want is to use this cheat:
COLOUR_QL BLOCK 1, 1, 0, 0, 6: REMark Yellow yellow% = RPIX%(0, 0) : REMark Proof? COLOUR_NATIVE: BLOCK#2; 50, 50, 0, 0, yellow%
Since the built-in FILL command in SBASIC does pretty much the same as both programs above, I haven't spent much time making them generally useful. The only problem with the built-in FILL is that it crashes the system if the screen size is larger than 1280x768 (I don't know the exact value but up to 1280x768 is fine, while 1680x1050 is not). This is still true as of SMSQ/E V3.36, but by the time you read this it may have been fixed.
Finally there is FFILL, which is based on the above but adapted to use a bitmap rather than a single colour for the colour replacement. This allows textures and even whole images to be used to fill the shape. Ie you could use this to, for example, draw an oval frame and fit a portrait inside it. (Which I then did in about ten minutes and put the result up top!)
1000 rem + ------------------------------------------------------------------------ + 1002 rem |< FFILL >| 1004 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 1006 rem | Scanline floodfill algorithm using a stack | 1008 rem | | 1010 rem | Based on an algorithm implemented by Tobias Fröschle: | 1012 rem | See https://qlforum.co.uk/viewtopic.php?f=3&t=2817&p=28590#p28593 | 1014 rem | | 1016 rem | It guarantees that every pixel to be filled is only visited exactly | 1018 rem | once. The drawing could be made faster, though, eg by drawing | 1020 rem | complete lines rather than single pixels.. | 1022 rem | | 1024 rem | This version uses a bitmap to fill the shape with, so you could use an | 1026 rem | image or some pattern or texture to fill the shape. The bitmap needs | 1028 rem | to be in the form of a standard PIC of the same mode as the display. | 1030 rem | | 1032 rem | This is a "skeleton routine", ie the source code needs to be modified | 1034 rem | for any particular use. | 1036 rem | | 1038 rem | GD2 only, modes 16, 32, and 33 - which also implies SMSQ/E only | 1040 rem | | 1042 rem | Dependencies: RPIX%, WPIX, WINDSZ (, PCBO%); Push, Pop, Eliminate | 1043 rem | GLOBal mode% | 1044 rem + ------------------------------------------------------------------------ + 1046 rem | V0.00, tofro, 2019 Jun 30 | 1048 rem | V0.01, pjw, 2022 Oct 27, bitmap implementation, optimisation & packaging | 1050 rem | V0.02, pjw, 2022 Nov 01, all GD2 modes | 1052 rem + ------------------------------------------------------------------------ + 1054 : 1056 DEFine PROCedure FFILL (channel, oldColour%, bitmap, x, y) 1058 LOCal stackLoop, leftLoop, rightLoop 1060 LOCal spanAbove, spanBelow, stack%(128), stackCtr% 1062 LOCal x%, y%, scrx%, scry%, newColour% 1064 LOCal xb, yb, yinc 1066 : 1068 rem Get inside window dimensions & line increment 1070 WINDSZ#channel; scrx%! scry%, x%, y% 1072 yinc = PEEK_W(bitmap + 6) 1074 x% = x: y% = y 1076 : 1078 stackCtr% = 0: Push x%, y% 1080 : 1082 rem Loop until stack empty 1084 REPeat stackLoop 1086 IF KEYROW(1) = 8: EXIT stackLoop: rem Get me outta here! 1088 IF stackCtr% <= 0: EXIT stackLoop 1090 Pop x%, y% 1092 : 1094 rem Search left boundary 1096 REPeat leftLoop 1098 IF x%< 0 : EXIT leftLoop 1100 IF RPIX% (#channel; x%, y%) <> oldColour% THEN 1102 EXIT leftLoop 1104 ELSE 1106 x%= x% - 1 1108 END IF 1110 END REPeat leftLoop 1112 x%= x%+ 1 1114 spanAbove = 0 1116 spanBelow = 0 1118 : 1120 rem Search right boundary 1122 REPeat rightLoop 1124 IF x%>= scrx% : EXIT rightLoop 1126 IF RPIX% (#channel; x%, y%) <> oldColour% THEN 1128 EXIT rightLoop 1130 END IF 1132 : 1134 rem Select replacement colour from bitmap location 1136 xb = x% MOD PEEK_W(bitmap + 2) 1138 yb = y% MOD PEEK_W(bitmap + 4) 1140 IF mode% = 16 THEN 1142 newColour% = PEEK(bitmap + 10 + yb * yinc + xb) 1144 ELSE 1146 xb = xb + xb: rem modes 32 & 33 2bpp 1148 newColour% = PEEK_W(bitmap + 10 + yb * yinc + xb) 1150 END IF 1152 rem If you want ALPHA_BLEND or OVER, use BLOCK instead of WPIX 1154 rem Then you also need PCBO% in mode 32 1156 rem if mode% = 32: PCBO% newColour%: rem Switch byte order 1158 rem BLOCK #channel, 1, 1, x%, y%, newColour% 1160 WPIX #channel; x%, y%, newColour% 1162 : 1164 rem Look into scanline above 1166 IF y% > 0 THEN 1168 IF spanAbove = 0 THEN 1170 IF RPIX% (#channel; x%, y% - 1) = oldColour% THEN 1172 Push x%, y% - 1 1174 spanAbove = 1 1176 END IF 1178 ELSE 1180 IF RPIX%(#channel; x%, y% - 1) <> oldColour% THEN 1182 spanAbove = 0 1184 END IF 1186 END IF 1188 END IF 1190 IF y% < (scry% - 1) THEN 1192 IF spanBelow = 0 THEN 1194 IF RPIX%(#channel; x%, y% + 1) = oldColour% THEN 1196 Push x%, y% + 1 1198 spanBelow = 1 1200 END IF 1202 ELSE 1204 IF RPIX% (#channel; x%, y% + 1) <> oldColour% THEN 1206 spanBelow = 0 1208 END IF 1210 END IF 1212 END IF 1214 x%= x%+ 1 1216 END REPeat rightLoop 1218 END REPeat stackLoop 1220 END DEFine FFILL 1222 : 1224 DEFine PROCedure Push(x, y) 1226 stack%(stackCtr%) = x 1228 stack%(stackCtr% + 1) = y 1230 stackCtr% = stackCtr% + 2 1232 END DEFine Push 1234 : 1236 DEFine PROCedure Pop(x, y) 1238 stackCtr% = stackCtr% - 1 1240 y = stack%(stackCtr%) 1242 stackCtr% = stackCtr% - 1 1244 x = stack%(stackCtr%) 1246 END DEFine Pop 1248 : 1250 : 1252 rem + ------------------------------------------------------------------------ + 1254 rem |< Eliminate >| 1256 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 1258 rem | Eliminate paper colour | 1260 rem | | 1262 rem | If paper colour found in pattern, alter it slightly so as not to | 1264 rem | confuse the algorithm. | 1266 rem | | 1268 rem | Dependency: PCBO% | 1270 rem + ------------------------------------------------------------------------ + 1272 rem | V0.01, pjw, 2022 Oct 29 | 1274 rem | V0.02, pjw, 2022 Nov 01, all GD2 modes | 1276 rem + ------------------------------------------------------------------------ + 1278 : 1280 DEFine PROCedure Eliminate(ad, fl, pa%) 1282 LOCal a, p%, f%, m% 1284 m% = DISP_TYPE 1286 : 1288 IF fl > 200000: BEEP 2000, 10: rem Warn of delay 1290 p% = pa% 1292 SELect ON m% 1294 = 32, 33 1296 IF m% = 32: PCBO% p% 1298 SELect ON pa% 1300 = -32768, 0 TO 32766: f% = pa% + 1 1302 = 32767, -32767 TO -1: f% = pa% - 1 1304 END SELect 1306 : 1308 FOR a = ad + 10 TO ad + fl - 2 STEP 2 1310 IF PEEK_W(a) = p%: POKE_W a, f% 1312 END FOR a 1314 = 16 1316 IF pa% = 0: f% = 1: ELSE : f% = pa% - 1 1318 FOR a = ad + 10 TO ad + fl - 1 1320 IF PEEK(a) = p%: POKE a, f% 1322 END FOR a 1324 END SELect 1326 : 1328 IF fl > 200000: BEEP 2000, 40 1330 END DEFine Eliminate
To run the demo you need to EXecute the SBASIC program thus:
EX <path>FFILL; <bitmap path and file name>
or alter the parameters you want and execute it directly via the SBAS/QD Thing in QD.
If rendering takes too long for your taste press ESC to abort. Press Q to quit.
The bitmap must be in the form of a PIC (the native QL image format) of the same mode as the display mode, whether it be 16, 32, or 33.
Note that if you want to use various effects like ALPHA_BLEND or OVER you need to change line 1160 to use BLOCK instead of WPIX. In the case of mode 32 (QPC2, SMSQmulator) you also have to swap the colour code's bytes around. You can use the included PCBO% (PC Byte Order). An explanation for this swapping around can be found here.
The latter routine cheats a bit in that the paper colour given (oldColour%) is used to determine whether a pixel has been visited, so a pixel of the same colour in the pattern would confuse it. Hence the pre-processing routine Eliminate, which slows things down. However, if you know that there are no pixels in the patterns of the same colour as the paper colour (eg because you already scanned the bitmap and saved the result) you can skip Eliminate. On the other hand if the bitmap is small the speed penalty will hardly be noticeable.
Finally, to produce the portrait shown at the top, the following code was added to the basic FFILL routine in place of the test harness. This should also give some ideas as to how the routine could be used:
10 EXT_PROC 'WINDSZ', 'WPIX', 'PCBO%' 11 EXT_FN 'FFILL%', 'RPT%', 'RPIX%' 12 IF NOT FFILL%: LRESPR HOME_DIR$ & 'FFILL_bin': rem Load if not loaded 13 : 14 : 100 rem + ------------------------------------------------------------------------ + 102 rem |< Portrait >| 104 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 106 rem | Create an oval frame and fill in a portrait | 108 rem | | 110 rem | EXecute this program with a suitable PICture as the parameter: | 112 rem | | 114 rem | EX <path>Portait; '<path>Mother_pic' | 116 rem | | 118 rem | Note: The PIC must be in the same mode as the display and must not be | 120 rem | larger than the screen. | 122 rem + ------------------------------------------------------------------------ + 124 rem | V0.01, pjw, 2022 Nov 02 | 126 rem | V0.02, pjw, 2022 Nov 04, All GD2 modes | 128 rem + ------------------------------------------------------------------------ + 130 : 132 COLOUR_QL 134 mode% = DISP_TYPE 136 paper% = 7: rem White paper in QL mode 138 : 140 rem Get a portrait off command line or use default 142 fnm$ = CMD$ 144 IF fnm$ = '': fnm$ = HOME_DIR$ & 'pat_' & mode% & '_QEIImini_pic' 146 : 148 rem Convert QL colour to NATIVE 150 ch = FOPEN("con") 152 BLOCK#ch; 1, 1, 0, 0, paper% 154 paper% = RPIX%(#ch; 0, 0): rem This is NATIVE Paper colour 156 : 158 rem Load some patterns and portrait, and initialise 160 pic = LoadPat(fnm$, paper%): ERT pic 162 pat0 = LoadPat("win1_prg_drw_fil_pat_" & mode% & "_pat0_pic", paper%): ERT pat0 164 pat8 = LoadPat("win1_prg_drw_fil_pat_" & mode% & "_pat8_pic", paper%): ERT pat8 166 : 168 rem Get metrics for Window 170 xs% = PEEK_W(pic + 2) 172 ys% = PEEK_W(pic + 4) 174 : 176 scx% = SCR_XLIM(#ch) 178 OUTLN#ch; xs% + 4, ys% + 2, (scx% - xs%) / 2, 30 180 INK#ch; 0 182 : 184 COLOUR_24: BORDER#ch; 2, $2F4F4F: rem DarkSlateGray 186 COLOUR_NATIVE: rem Switch colour traps to NATIVE 188 PAPER#ch; paper%: CLS#ch 190 : 192 rem Draw portrait frame 194 ELLIPSE#ch; 50 * xs% / ys%, 50, 33, 1.5, PI/2 196 ELLIPSE#ch; 50 * xs% / ys%, 50, 30, 1.5, PI/2 198 : 200 rem Fill sourroundings. Sometimes frame hits border and divides area.. 202 FloodFill#ch; paper%, pat0, 10, 10 204 FloodFill#ch; paper%, pat0, xs% - 10, 10: rem In case area divided 206 : 208 rem Find & fill frame outline. 210 y% = ys% / 2: rem Middle 212 FOR x% = 2 TO xs% / 2 STEP 2 214 IF RPIX%(#ch; x%, y%) = paper% THEN 216 FloodFill#ch; paper%, pat8, x%, y% 218 EXIT x% 220 END IF 222 END FOR x% 224 : 226 rem Fit portrait into frame 228 FloodFill#ch; paper%, pic, xs% / 2, y% 230 : 232 rem Done. Here the result could be saved.. 234 PAUSE#ch 236 IF JOBID: QUIT: ELSE : RECHP adr: STOP 238 : 240 : 242 rem Load pattern and initialise 244 DEFine FuNction LoadPat(nm$, pap%) 246 LOCal fln, adr 248 fln = FLEN(\ nm$) 250 adr = ALCHP(fln): LBYTES nm$, adr 252 IF PEEK(adr + 8) <> DISP_TYPE: RECHP adr: RETurn -19 254 Eliminate adr, fln, pap%: rem Eliminate paper colour from pattern! 256 RETurn adr 258 END DEFine LoadPat 260 : 262 :
The complete demo can be found as Portrait_bas. EXecute it with a suitable image on the commandline. (The one included is a poor miniature to save space.)
All the code, toolkits and an assortment of bitmaps for you to try can be downloaded by clicking on the link below. Simply unzip the file to a suitable location like RAM1_ to test the demos. You may need to LRESPR the FFILL_BIN toolkit first, except for the FFILL demos which load and unload the toolkit as required.
QL Software
