QL Software
100 rem $$asmb=win1_uti_spr_Spr2RLE_bin,0,10 102 : 104 rem + ------------------------------------------------------------------------ + 106 rem |< Spr2RLE >| 108 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 110 rem | Compress a simple, single GD2 sprite | 112 rem | | 114 rem | PRINT FEW(<path>Spr2RLE; '<input file name>') | 116 rem | or | 118 rem | | 120 rem | PRINT FEW(<path>Spr2RLE; '/F"<input file name>" [/O<output file name>]') | 122 rem | | 124 rem | If no output file name given result overwrites ram1_sprite_spr | 126 rem | | 128 rem | With either just a pattern or a mask, or both. | 130 rem | Assumes sprite is made in a regular/standard way, without sprite, block, | 132 rem | options or chained sprites. If any part of the sprite is already | 134 rem | compressed it gives up. | 136 rem | | 138 rem | Dependencies: BTST%; tks ENRLE, EVEN, DETAB$ | 140 rem + ------------------------------------------------------------------------ + 142 rem | V0.01, pjw, 2019 Jun 10 | 144 rem | V0.02, pjw, 2024 Sep 02, debugged and much improved | 146 rem + ------------------------------------------------------------------------ + 148 : 150 : 152 EXT_FN 'ENRLE', 'EVEN', 'DETAB$' 154 : 156 quote$ = '"' & "'" 158 spr = GetCmd(CMD$) 160 IF spr < 0: QUIT er 162 : 164 fl = FLEN(#spr): CLOSE#spr 166 spr = ALCHP(fl + fl + 16) 168 tsp = spr + fl: rem New sprite address.. 170 LBYTES ifn$, spr: rem ..in top half of buffer 172 : 174 ctr% = PEEK(spr + 3): rem Control byte 176 : 178 rem Weed out stuff we dont handle 180 IF PEEK(spr) <> 2: Tidy -19: rem GD2 only 182 IF BTST%(ctr%, 7) OR BTST%(ctr%, 6): Tidy -8: rem Some data was already compressed 184 IF BTST%(ctr%, 4) OR BTST%(ctr%, 2): Tidy -19: rem Cant handle Options or Sprite Block 186 IF PEEK_L(spr + 20): Tidy -14: rem No chained sprites 188 : 190 hdsz = 24: rem Header size of simple sprite 192 md% = PEEK(spr + 1): rem Colour mode 194 SELect ON md% 196 = 16: rlesz = 1 198 = 32, 33: rlesz = 2: rem Work out blob's RLE element size 200 = 64: rlesz = 4 202 = REMAINDER : Tidy -19: rem We only handle these sprites 204 END SELect 206 sx = PEEK_W(spr + 4): rem X size 208 sy = PEEK_W(spr + 6): rem Y-size 210 : 212 rem Get pattern (if any) 214 IF PEEK_L(spr + 12) THEN 216 patadr = spr + PEEK_L(spr + 12) + 12: rem Abs addr of pattern data 218 ELSE 220 patadr = 0 222 END IF 224 : 226 rem Get mask (if any) 228 IF PEEK_L(spr + 16) THEN 230 mskadr = spr + PEEK_L(spr + 16) + 16: rem Abs addr of mask data 232 alpha = ctr% && 32: rem alpha <> 0 if alpha 234 ELSE 236 mskadr = 0: alpha = 0 238 END IF 240 : 242 rem Calculate data size 244 patsz = 4 * INT((sx * rlesz + 3) / 4) * sy: rem Data size, rounded to nearest long 246 patsz = EVEN(patsz): rem Round up to even 248 IF NOT alpha THEN 250 msksz = patsz: rem Mask size same as pattern.. 252 ELSE 254 msksz = EVEN(sx * sy): rem ..unless alpha 256 END IF 258 npsz = 0: rem New pattern size 260 nmsz = 0: rem New mask size 262 : 264 rem Do it! 266 rlex = 0: rem Extra room for RLE header(s) 268 IF patadr THEN 270 npsz = ENRLE(patadr, tsp + hdsz + 8, patsz, rlesz): rem New pattern size 272 IF npsz < 0: Tidy npsz: rem Doesnt compress 274 : 276 POKE$ tsp + hdsz, 'RLE' & rlesz: rem Set RLE header 278 POKE_L tsp + hdsz + 4, patsz 280 ctr% = ctr% || 64: rem Flag pattern compressed 282 rlex = 8: rem This much added to data 284 END IF 286 : 288 nxadr = tsp + hdsz + npsz + rlex: rem Next address 290 IF mskadr THEN 292 IF alpha THEN 294 nmsz = ENRLE(mskadr, nxadr + 8, msksz, 1) 296 ELSE 298 nmsz = ENRLE(mskadr, nxadr + 8, msksz, rlesz) 300 END IF 302 IF nmsz < 0: Tidy nmsz: rem Doesnt compress 304 : 306 IF alpha THEN : rem Set RLE header 308 POKE$ nxadr, 'RLE1' 310 ELSE 312 POKE$ nxadr, 'RLE' & rlesz 314 END IF 316 POKE_L nxadr + 4, msksz 318 ctr% = ctr% || 128: rem Flag mask compressed 320 rlex = rlex + 8: rem Add room for header 322 END IF 324 : 326 rem Save sprite 328 POKE$ tsp, PEEK$(spr, hdsz) 330 POKE tsp + 3, ctr%: rem Blob and/or Pattern compressed 332 IF patadr THEN 334 POKE_L tsp + 12, 12: rem Offset to pattern.. 336 ELSE 338 POKE_L tsp + 12, 0: rem ..unless none 340 END IF 342 IF mskadr THEN 344 IF npsz THEN 346 POKE_L tsp + 16, npsz + 16: rem Offset to mask.. 348 ELSE 350 POKE_L tsp + 16, 8: rem ..but no pattern => blob 352 END IF 354 ELSE 356 POKE_L tsp + 16, 0: rem No mask 358 END IF 360 : 362 SBYTES_O ofn$, tsp, hdsz + npsz + nmsz + rlex 364 BEEP 2000, 2: Tidy 0: rem All ok! 366 : 368 : 370 rem + ************************************************************************ + 372 rem *< General Utils >* 374 rem + ************************************************************************ + 376 : 378 : 380 DEFine FuNction BTST%(flg%, btn%) 382 RETurn (2 ^ btn% && flg%) <> 0 384 END DEFine BTST% 386 : 388 : 390 DEFine PROCedure Tidy(er) 392 RECHP spr 394 IF er <> 0: BEEP 2000, 200: rem Error: Burp 396 QUIT er 398 END DEFine Tidy 400 : 402 : 404 rem + ------------------------------------------------------------------------ + 406 rem |< Command Line >| 408 rem + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 410 rem | Parses command line and sets defaults | 412 rem | | 414 rem | /F - Input file name | 416 rem | /O - Output file name (optional) | 418 rem | | 420 rem | Dependencies: DETAB$ | 422 rem | GLOBal quote$ | 424 rem + ------------------------------------------------------------------------ + 426 rem | V0.01, pjw, 2019 Jul 01, base version | 428 rem | V0.01, pjw, 2024 Sep 02, Spr2RLE version 430 rem + ------------------------------------------------------------------------ + 432 : 434 DEFine FuNction GetCmd(cl$) 436 LOCal p%, t$(50) 438 : 440 IF cl$ = '': RETurn -15 442 : 444 rem Get input file name 446 ifn$ = Getent$("F") 448 IF ifn$ = '' THEN 450 ifn$ = cl$ 452 ofn$ = 'ram1_sprite_spr' 454 ELSE 456 ofn$ = Getent$('O') 458 IF ofn$ = '': ofn$ = 'ram1_sprite_spr' 460 END IF 462 : 464 RETurn FOP_IN(ifn$) 466 END DEFine GetCmd 468 : 470 DEFine FuNction Getent$(c$) 472 rem Caller's cl$, p%, t$ 474 rem Given the character get the entry 476 rem /C [<spaces>] ["|'] <entry> ["|'] <space> | <space> /C+1 | <eol> 478 : 480 p% = '/' & c$ INSTR cl$ 482 IF p% = 0: RETurn '' 484 t$ = DETAB$(cl$(p% + 2 TO LEN(cl$))) 486 p% = ' /' INSTR t$ 488 IF p% > 0: t$ = t$(1 TO p%): ELSE : p% = LEN(t$) 490 FOR p% = LEN(t$) TO 1 STEP -1 492 IF NOT t$(p%) INSTR ' /': EXIT p% 494 END FOR p% 496 : 498 t$ = t$(1 TO p%) 500 IF LEN(t$) > 1 THEN 502 p% = t$(1) INSTR quote$ 504 IF p% THEN 506 IF (t$(LEN(t$)) INSTR quote$) = p% THEN 508 t$ = t$(2 TO LEN(t$) - 1) 510 END IF : END IF : END IF 512 RETurn t$ 514 END DEFine Getent$ 516 : 518 :
QL Software