\ Make mosaics of tiny square stones with specific constraints on their relative position. \ hk May 2026 Tested with Gforth and noForth \ Programmeeropgave van Albert Nijhof voor juni 2026 \ See: http://forth-ig.nl/downloads/2026/Juni/tegels(douche)%20opgave.pdf \ \ To make the colours and other text attributes work in your terminal \ an option 'Handle ANSI formatting sequences' or similar should be activated. decimal 8 cells constant CSIZE \ Cell size (machine word size) 16 constant SIDE SIDE dup * constant UPPLim \ Upper limit for the random numbers 0 value stones \ Counter for the stones in the mosaic 1 value width \ Width of the tiles; set by SMAL & BREED False value grouted \ Boolean for grouted ('gevoegd') tiles or not 1 value beside \ Tiles next to each other 1 value below \ Tiles below each other variable oneRow \ Variable for different versions of PrintRow variable bg \ Background colour \ Cell-size agnostic PRNG (at least for 32- & 64-bits Forths) variable seed \ The same seed gives the same random numbers hex : Force32 ( n -- u32 ) FFFFFFFF AND ; \ Force 32 bits, also on 64-bits system decimal : Random ( -- n ) seed @ 31421 * 6927 + Force32 dup seed ! ; : Choose ( lim -- rn ) \ rn is a random number, 0 ≤ rn < lim Random \ Split the 32-bit random number into high and low 16-bit halves dup 65535 AND swap 16 rshift ( lim lo hi ) \ 0-filled right shift 16 places \ Multiply both halves by the limit and add them rot dup rot * ( lo lim lim*hi ) 16 rshift ( lo lim lim*hi' ) rot rot ( lim*hi' lo lim ) * + ( lim*hi'+lo*lim ) 16 rshift Force32 ; ( scaled-result ) : B. ( n -- ) base @ >r 2 base ! u. r> base ! ; : AllBits. ( n -- ) \ Uses the leftmost (sign) bit ( = 1 if n < 0 ) CSIZE 0 DO dup 0< IF [char] 1 ELSE [char] 0 THEN emit 2* \ Shift left LOOP drop ; : Bin. ( n ---) base @ >r 2 base ! 0 <# # # # # # # # # # # # # # # # # # # #> \ Format as 18 digits type r> base ! ; : ClSt ( i*x -- ) DEPTH 0 ?DO DROP LOOP ; \ Clear the stack : **bis ( bit-mask adr -- ) tuck @ OR swap ! ; \ Set bit(s) of the mask in adr \ Array of bitstrings. Only the rightmost SIDE+2 bits are used; two extra marginal rows. \ The extra margins (above, below, left, right) facilitate the Neighbrs? algorithm. create BITS SIDE 2 + cells allot : Bits! ( n index -- ) cells bits + ! ; \ bits[index] := n : Bits@ ( index -- n ) cells bits + @ ; \ TOS := bits[index] : BitsAdr ( index -- a ) cells bits + ; \ TOS := Address(bits[index]) : BitsReset ( -- ) SIDE 2 + 0 DO 0 i Bits! LOOP ; \ Reset all bits to 0 : CellSizeCheck ( -- ) SIDE 2 + CSIZE > IF cr ." Error: cell size of this Forth is too small." ABORT THEN ; : Rnd>Pos ( rn -- row offs ) SIDE /mod 1+ swap 1+ ; \ Random # to position: array row (index), bit offset : Mask1 ( offset -- mask ) 1 swap lshift ; \ mask with one bit set: …1b = 1 : Mask5 ( offset -- mask ) 5 swap 1- lshift ; \ mask with two bits set: …101b = 5 : Mask7 ( offset -- mask ) 7 swap 1- lshift ; \ mask with three bits set: …111b = 7 : Mask1+S ( -- mask ) SIDE 1+ Mask1 2 OR ; \ mask for bit on right edge : MaskS+1 ( -- mask ) SIDE Mask1 1 OR ; \ mask for bit on left edge : PosFree? ( row offs -- flag ) Mask1 >r Bits@ r> AND 0= ; \ True if bits[offs] = 0 : Above ( row offs -- 0 | mask ) Mask7 >r 1- Bits@ r> AND ; \ 0 if no neighbours : Under ( row offs -- 0 | mask ) Mask7 >r 1+ Bits@ r> AND ; \ 0 if no neighbours : Line ( row offs -- 0 | mask ) Mask5 >r Bits@ r> AND ; \ 0 if no neighbours : Neighbrs? ( row offs -- 0 | mask ) \ 0 if no neighbours, neither at the margin swap >r >r ( row offs - ) ( R: row offs) 2r@ Above ( -- 0 | mask ) 2r@ Under OR ( 0 | mask -- 0 | mask ) 2r@ Line OR ( 0 | mask -- 0 | mask ) r> r> 2drop ; ( 0 | mask -- 0 | mask ) : Mask ( offs -- mask ) \ Mask to set 1 bit in a row, with special cases at margin dup 1 = IF Mask1+S ELSE dup SIDE = IF MaskS+1 ELSE Mask1 THEN THEN ; : BitsUpdate ( row offs -- ) \ Update the array of bitstrings swap >r ( row offs -- offs ) ( R: row ) Mask ( offs -- mask ) r@ BitsAdr **bis \ set the mask-bits in the row r@ 1 = IF 1 Bits@ SIDE 1+ Bits! THEN \ copy row 1 to the lower margin r@ SIDE = IF SIDE Bits@ 0 Bits! THEN \ copy row SIDE to the upper margin r> drop ; : FillMosaic ( seed -- ) seed ! BitsReset cr 0 to stones \ Initialize the count of the stones BEGIN UPPLim Choose ( -- rn ) \ Random number in {0..UPPLim-1} \ dup ." rn = " . cr Rnd>Pos ( rnd -- row offs ) \ row: array-index, offs: bit-offset 2dup swap >r >r ( row offs -- row offs ) ( R: row offs ) PosFree? IF \ Is that position free (bitvalue = 0) ? 2r@ Neighbrs? 0= IF \ Any neighbours? 2r@ BitsUpdate \ Update the array of bitstrings stones 1+ to stones \ Increment the count THEN ELSE THEN r> r> ClSt stones SIDE = UNTIL ; : CSI ( addr len -- ) \ General ANSI escape code handler for strings that are \ prefixed with Esc[ ('Control Sequence Introducer', CSI). \ Use: s" ccc" CSI E.g.: s" 1;104m" CSI s" 0m" CSI \ See: https://en.wikipedia.org/wiki/ANSI_escape_code#CSIsection >r >r 27 emit [char] [ emit r> r> type ; : SGR ( n -- ) \ Specific ANSI escape code handler for display attributes. \ ('Select Graphic Rendition', SGR = Esc[...m ) \ Use: n SGR \ See: https://en.wikipedia.org/wiki/ANSI_escape_code#SGR \ E.g.: 1 bold/bright text, 104 bright blue background, 7 reverse video, 0 standard 27 emit [char] [ emit 0 .r [char] m emit ; \ *Attribute* *Colour* *Foreground* *Background* *Bright FG* *Bright BG* \ 0 None Black 30 40 90 100 \ 1 Bright Red 31 41 91 101 \ 2 Dim Green 32 42 92 102 \ 4 Underline Yellow 33 43 93 103 \ 5 Blink Blue 34 44 94 104 \ 7 Reverse video Magenta 35 45 95 105 \ 8 Invisible Cyan 36 46 96 106 \ White 37 47 97 107 \ E.g.: 1 SGR ( bold/bright text ) 104 SGR ( bright blue background ) 0 SGR ( standard ) : Stone ( -- ) 7 SGR 2 spaces 0 SGR 1 SGR bg @ execute ( s" 0;1;104m" CSI ) ; : Stone* ( -- ) 1 SGR 5 SGR [char] # emit [char] # emit s" 0;1;104m" CSI ; \ just a joke : PrintRow* ( bits[i] -- ) \ Output: asterisks on bright blue background \ Iterate through the bits applying a mask to select a specific bitfield. bg @ execute \ Set background colour \ s" 1;104m" CSI \ bright white text on a bright blue background SIDE 1+ 1 DO \ Print SIDE bits, start with bit 1 dup 65536 AND \ masks 15 bits: 32768 16 bits: 65536 17 bits: 131072 0 > IF [char] * emit width 2 = IF space THEN ELSE width spaces THEN 2* \ Shift left LOOP drop 104 SGR ; : PrintRow** ( bits[i] -- ) \ Output: blinking asterisks on bright blue background \ Iterate through the bits applying a mask to select a specific bitfield. bg @ execute \ Set background colour s" 1;5;104m" CSI \ bright blinking white text on a bright blue background SIDE 1+ 1 DO \ Print SIDE bits, start with bit 1 dup 65536 AND \ masks 15 bits: 32768 16 bits: 65536 17 bits: 131072 0 > IF [char] * emit width 2 = IF space THEN ELSE width spaces THEN 2* \ Shift left LOOP drop 0 SGR ; \ Back to standard colours to stop the blinking : PrintRow ( bits[i] -- ) \ Output: white squares on blue background \ Iterate through the bits applying a mask to select a specific bitfield bg @ execute \ Set background colour \ s" 1;104m" CSI \ Bright white text on a bright blue background SIDE 1+ 1 DO \ Print SIDE bits, start with bit 1 dup 65536 AND \ masks 15 bits: 32768 16 bits: 65536 17 bits: 131072 0 > IF Stone ELSE 2 spaces THEN 2* \ Shift left LOOP drop 0 SGR ; \ Back to standard colours : PrintRow1 ( bits[i] -- ) \ Output: binary digits \ Iterate through the bits applying a mask to select a specific bitfield. SIDE 1+ 1 DO \ Print SIDE bits, start with bit 1 dup 65536 AND \ masks 15 bits: 32768 16 bits: 65536 17 bits: 131072 0 > IF [char] 1 ELSE [char] 0 THEN emit 2* \ Shift left LOOP DROP ; : PrintRow2 ( bits[i] -- ) Bin. ; : PrintMosaic* ( -- ) cr SIDE 1+ 1 DO i Bits@ PrintRow* cr LOOP ; : PrintMosaic ( -- ) cr SIDE 1+ 1 DO i Bits@ PrintRow cr LOOP ; : PrintBin ( -- ) cr SIDE 1+ 1 DO i Bits@ PrintRow1 cr LOOP ; : PrintAll ( -- ) cr SIDE 2 + 0 DO i Bits@ PrintRow2 cr LOOP ; : PrintAllBits ( -- ) cr SIDE 2 + 0 DO i Bits@ AllBits. cr LOOP ; : Home ( -- ) s" H" CSI ; \ Cursor to left upper corner : Page ( -- ) Home s" 2J" CSI ; \ Clear screen : Blauw ( -- ) s" 1;104m" CSI ; : Magenta ( -- ) s" 1;105m" CSI ; : Leuk! ( -- ) ['] Magenta bg ! ; : Blauw! ( -- ) ['] Blauw bg ! ; : P ( nr -- ) FillMosaic ; variable ij : .P0 ( hor ver -- ) cr grouted IF cr THEN \ 'grouted': gevoegd, met voegen below 0 DO \ Number of (sequences of) tiles below each other SIDE 1+ 1 DO \ Each tile has SIDE rows i ij ! \ noForth has no J ... beside 0 DO \ One (sequence of a) row of beside tile(s) ij @ Bits@ oneRow @ execute grouted IF 2 spaces THEN LOOP cr LOOP grouted IF cr THEN LOOP ( cr ) ; : .P ( hor ver -- ) to below to beside False to grouted ['] PrintRow* oneRow ! .P0 ; : .P* ( hor ver -- ) to below to beside False to grouted ['] PrintRow** oneRow ! .P0 ; : .PP ( hor ver -- ) to below to beside False to grouted 0 SGR page ['] PrintRow oneRow ! .P0 ; : .PPP ( hor ver -- ) to below to beside True to grouted 0 SGR page ['] PrintRow oneRow ! .P0 ; : SMAL ( -- ) 1 to width ; : BREED ( -- ) 2 to width ; CellSizeCheck Blauw ' Blauw bg !