Concatenative topics
Concatenative meta
Other languages
Meta
The Sierpinski triangle of order 4 should look like this:
                       *
                      * *
                     *   *
                    * * * *
                   *       *
                  * *     * *
                 *   *   *   *
                * * * * * * * *
               *               *
              * *             * *
             *   *           *   *
            * * * *         * * * *
           *       *       *       *
          * *     * *     * *     * *
         *   *   *   *   *   *   *   *
        * * * * * * * * * * * * * * * *
@on-reset ( -> )
	[ LIT &size 20 ] STHk #01 SUB
	&ver ( -- )
		DUP
		#00 EQUk ?{
			&pad ( -- )
				#2018 DEO
				INC GTHk ?&pad
		} POP 
		#00
		&fill
			ANDk #202a ROT ?{ SWP } POP #18 DEO
			#2018 DEO
			INC ADDk STHkr LTH ?&fill
		POP2
		#0a18 DEO
		#01 SUB INCk ?&ver
	POP POPr
	BRK
:N 16;
N [ dup                         (y) 
    [' .c] dotimes              (print padding)
    N [ dup                     (x)
        over2 drop 1-           (y' = y - 1)
        swap N !-               (x' = N - x)
        &                       (x' & y')
        \'  \'* ifte .c ' .c ]  (print * or space)
    dotimes .nl]       
dotimes: plot ( i j -- )
    bitand zero? "* " "  " ? write ;
: pad ( n -- ) 
    1 - [ bl ] times ;
: plot-row ( n -- ) 
    dup 1 + [ tuck - plot ] with each-integer ;
: sierpinski ( n -- )
    dup '[ _ over - pad plot-row nl ] each-integer ;vocab each_int:
    define helper<+P> (Int32, Int32, (Int32 -> +P) -> +P):
        -> n, i, f ;
        if (i < n):
            i f call
            n (i + 1) f helper
    
define each_int<+P> (Int32, (Int32 -> +P) -> +P):
    zero swap each_int::helper
define with_arg<R1..., R2..., T, A, B, S..., +P2, +P1>(R1..., T, B, (R2..., T, A -> S... +P2) -> R1..., B, (R2..., A -> S... +P1) +P1):
    {swap} dip {{swap} dip call} apply apply
define plot (Int32, Int32 -> +IO):
    (&) zero (=) if {"* "} else {"  "} print
define over<A, B> (A, B -> A, B, A):
    -> a, b; a b a
define tuck<A, B> (A, B -> B, A, B):
    swap over
define times<+P> (Int32, (-> +P) -> +P):
    {drop} swap compose each_int
define pad (Int32 -> +IO):
    1 (-) {" " print} times 
define plot_row (Int32 -> +IO):
    dup 1 (+) {tuck (-) plot} with_arg each_int
define sierpinski (Int32 -> +IO):
    dup {over (-) pad plot_row "\n" print} apply each_int
16 sierpinski: star ( -- )       [char] * emit space ;
: plot ( i j -- )   and 0= if star else 2 spaces then ;
: padd ( n -- )     0 +do space loop ;
: 2^   ( n -- 2^n ) dup 0= if 1 else 1- 2 swap lshift then ;
: sierpinski ( o -- )
  2^ dup 1- -1 swap -do
    i padd dup 0 +do
      i j plot
    loop cr
  1 -loop ;
4 sierpinski
	This revision created on Fri, 8 Mar 2024 23:11:16 by lobo