#
# snusp.icn, A Modular SNUSP interpreter
#

$define VERSION 0.6

# allow a couple of cli options
link options

# directions
$define DRIGHT 1
$define DLEFT  2
$define DUP    3
$define DDOWN  4

record position(row, col)
global dir, ip, ram

procedure main(argv)
   local ch, codespace, col, dp, fn, line
   local row := 1
   local wid := 0
   local dirs := []
   local ips := []
   local opts, verbose, debug

   opts := options(argv, "-h! -v! -d!", errorproc)
   \opts["v"] & verbose := 1
   \opts["h"] & show_help(verbose)
   \opts["d"] & debug := 1

   ip := position(1,1)

   # initial direction
   dir := DRIGHT

   # prepare initial memory
   ram := list(1, 0)

   # prepare code field
   codespace := []

   fn := open(argv[1], "r") | &input
   if (fn === &input) & \opts["h"] then return

   while line := read(fn) do {
      put(codespace, line)
      wid := max(*line, wid)
   }
   if *codespace = 0 then return
   every line := !codespace do {
      codespace[row] := left(codespace[row], wid)
      # track starting indicator
      if /col := find("$", codespace[row]) then {
         ip.row := row
         ip.col := col
      }
      row +:= 1
   }

   if \verbose then {
      write("Starting at ", ip.row, ", ", ip.col, " with codespace:")
      every write(!codespace)
   }

   dp := 1
   repeat {
      if not (ch := codespace[ip.row][ip.col]) then break
      if \debug then {
         write(&errout, "dir: ", dir, " ch: ", ch, " [", ord(ch), "]",
                        " row: ", ip.row, " col: ", ip.col,
                        " dp: ", dp, " ram[dp]: ", ram[dp])
      }
      case ch of {
         # six of the bf instructions
         "+": ram[dp] +:= 1
         "-": ram[dp] -:= 1
         ">": resize(dp +:= 1)
         "<": dp -:= 1
         ".": writes(char(ram[dp]) | char(0))
         ",": ram[dp] := getche()
         # direction change, LURD, RULD, SKIP, SKIPZ
         "\\": { # LURD
            case dir of {
               DRIGHT: dir := DDOWN
               DLEFT:  dir := DUP
               DUP:    dir := DLEFT
               DDOWN:  dir := DRIGHT
            }
         }
         "/": { # RULD
            case dir of {
               DRIGHT: dir := DUP
               DLEFT:  dir := DDOWN
               DUP:    dir := DRIGHT
               DDOWN:  dir := DLEFT
            }
         }
         "!": step()
         "?": { # skipz
            if ram[dp] = 0 then {
               step()
            }
         }
         # modular SNUSP
         "@": { # Enter
            push(dirs, dir)
            push(ips, copy(ip))
         }
         "#": { # Leave
            if *dirs < 1 then break
            dir := pop(dirs)
            ip := pop(ips)
            step()
         }
      }
      step()
   }
end

# advance the ip depending on direction
procedure step()
   case dir of {
      DRIGHT: ip.col +:= 1
      DLEFT:  ip.col -:= 1
      DUP:    ip.row -:= 1
      DDOWN:  ip.row +:= 1
   }
end

# enlarge memory when needed
procedure resize(elements)
   until *ram >= elements do put(ram, 0)
end

# quick help or verbose help
procedure show_help(verbose)
   write("SNUSP interpeter in Unicon, version ", VERSION)
   write("CORE and MODULAR, not yet BLOATED")
   write()
   write("Usage: unicon snusp.icn -x [filename] [-h|-v|-d]")
   write(" -h, help")
   write(" -v, verbose (and verbose help")
   write(" -d, debug (step tracer)")
   if \verbose then {
      write()
      write("Instructions:")
      write(" + INCR,  Increment current memory location")
      write(" - DECR,  Decrement current memory location")
      write(" > RIGHT, Advance memory pointer")
      write(" < LEFT,  Retreat memory pointer")
      write(" . WRITE, Output contents of current memory cell, in ASCII")
      write(" , READ,  Accept key and place byte value in current memory cell")
      write(" \\ LURD, If going:")
      write("           left,  go up")
      write("           up,    go left")
      write("           right, go down")
      write("           down,  go right")
      write(" / RULD, If going:")
      write("           right, go up")
      write("           up,    go right")
      write("           left,  go down")
      write("           down,  go left")
      write(" !, SKIP,  Move forward one step in current direction")
      write(" ?, SKIPZ, If current memory cell is zero then SKIP")
      write("Modular SNUSP adds:")
      write(" @, ENTER, Push direction and instruction pointer")
      write(" #, LEAVE, Pop direction and instruction pointer and SKIP")
      write()
      write("All other characters are NOOP, explicitly includes =,|,spc")
      write(" $, can set the starting location; first one found")
      write()
      write("Hello world examples:")
      write()
      write("CORE SNUSP:")
      write("/++++!/===========?\\>++.>+.+++++++..+++\\")
      write("\\+++\\ | /+>+++++++>/ /++++++++++<<.++>./")
      write("$+++/ | \\+++++++++>\\ \\+++++.>.+++.-----\\")
      write("      \\==-<<<<+>+++/ /=.>.+>.--------.-/")
      write()
      write("Modular SNUSP:")
      write("      /@@@@++++#               #[email protected]@\                #[email protected]@@\\n")
      write("[email protected]\\[email protected]/e.+++++++l.l.+++o.>>++++.< .<@/[email protected]\\[email protected]\\[email protected]\\d.>[email protected]/.#")
      write("  \\@@@@=>++++>+++++<<@+++++#       #[email protected]@/!=========/!==/")
      write()
   }
end


(defmacro if2 (cond1 cond2 both first second &rest neither)
  (let ((res1 (gensym))
        (res2 (gensym)))
    `(let ((,res1 ,cond1)
           (,res2 ,cond2))
       (cond ((and ,res1 ,res2) ,both)
             (,res1             ,first)
             (,res2             ,second)
             (t                 ,@neither)))))


class Main
{
  static Int fib (Int n)
  {
    if (n < 2) return n
    fibNums := [1, 0]
    while (fibNums.size <= n)
    {
      fibNums.insert (0, fibNums[0] + fibNums[1])
    }
    return fibNums.first
  }

  public static Void main ()
  {
    20.times |n|
    {
      echo ("Fib($n) is ${fib(n)}")
    }
  }
}


def factors(num: Int) = {
    (1 to num).filter { divisor =>
      num % divisor == 0
    }
}


(define (factors n)
  (define (*factors d)
    (cond ((> d n) (list))
          ((= (modulo n d) 0) (cons d (*factors (+ d 1))))
          (else (*factors (+ d 1)))))
  (*factors 1))

(display (factors 1111111))
(newline)


void if2(T1, T2, T3, T4)(in bool c1, in bool c2,
                         lazy T1 first,
                         lazy T2 both,
                         lazy T3 second,
                         lazy T4 none) {
    if (c1) {
        if (c2)
            both;
        else
            first;
    } else {
        if (c2)
            second;
        else
            none;
    }
}

void test(in bool a, in bool b) {
    import std.stdio;
    if2(a, b, writeln("first"),
              writeln("both"),
              writeln("second"),
              writeln("none"));
}

void main() {
    test(1 < 2, 3 > 4);
    test(1 < 2, 1 < 2);
    test(3 > 4, 3 > 4);
    test(3 > 4, 1 < 2);
}


procedure Check(Condition1: Boolean; Condition2: Boolean)
begin
  if Condition1 = True then
  begin
    if Condition2 = True then
      BothConditionsAreTrue
    else
      FirstConditionIsTrue;
  end
  else
    if Condition2 = True then
      SecondConditionIsTrue
    else
      NoConditionIsTrue;
end;


Func Fibonacci(n) = if n<0 then -(-1)^n*Fibonacci(-n) else if n<2 then n else
    Array fib[n+1];
    fib[1] := 0;
    fib[2] := 1;
    for i = 2, n do
    fib[i+1]:=fib[i]+fib[i-1]
    od;
    Return(fib[n+1]);
    fi;
    fi;
    .


$ include "seed7_05.s7i";

const proc: writeFactors (in integer: number) is func
  local
    var integer: testNum is 0;
  begin
    write("Factors of " <& number <& ": ");
    for testNum range 1 to sqrt(number) do
      if number rem testNum = 0 then
        if testNum <> 1 then
          write(", ");
        end if;
        write(testNum);
        if testNum <> number div testNum then
          write(", " <& number div testNum);
        end if;
      end if;
    end for;
    writeln;
  end func;

const proc: main is func
  local
    const array integer: numsToFactor is [] (45, 53, 64);
    var integer: number is 0;
  begin
    for number range numsToFactor do
      writeFactors(number);
    end for;
  end func;


Factors(num(0))[i] := i when num mod i = 0 foreach i within 1 ... num;


pragma.enable("lambda-args") # The feature is still experimental syntax

def makeIf2Control(evalFn, tf, ft, ff) {
  return def if2Control {
    to only1__control_0(tf) { return makeIf2Control(evalFn, tf, ft, ff) }
    to only2__control_0(ft) { return makeIf2Control(evalFn, tf, ft, ff) }
    to else__control_0 (ff) { return makeIf2Control(evalFn, tf, ft, ff) }
    to run__control() {
      def [[a :boolean, b :boolean], # Main parameters evaluated
           tt                        # First block ("then" case)
          ] := evalFn()
      return (
        if (a) { if (b) {tt} else {tf} } \
          else { if (b) {ft} else {ff} }
      )()
    }
  }
}

def if2 {
    # The verb here is composed from the keyword before the brace, the number of
    # parameters in the parentheses, and the number of parameters after the
    # keyword.
    to then__control_2_0(evalFn) {
        # evalFn, when called, evaluates the expressions in parentheses, then
        # returns a pair of those expressions and the first { block } as a
        # closure.
        return makeIf2Control(evalFn, fn {}, fn {}, fn {})
    }
}

for a in [false,true] {
    for b in [false,true] {
        if2 (a, b) then {
            println("both")
        } only1 {
            println("a true")
        } only2 {
            println("b true")
        } else {
            println("neither")
        }
    }
}


# (fib n) = the nth Fibonacci number
\fib=
    (
    \loop==
        (\x\y\n
        le n 0 x;
        \z=(+ x y)
        \n=(- n 1)
        loop y z n
        )
    loop 0 1
    )

# Now test it:
for 0 20 (\n say (fib n))


[email protected](Integer traits) primeFactors
[
  [| :result |
   result nextPut: 1.
   n primesDo: [| :prime | result nextPut: prime]] writingAs: {}
].


(define-syntax-rule
	(if2 cond1 cond2 both cond1-only cond2-only none) ;; new syntax
;; will expand to :
	(if cond1
		(if cond2 both cond1-only)
		(if cond2 cond2-only none)))
   → #syntax:if2

(define (num-test n)
    (if2 (positive? n) (exact? n)
	  "positive and exact"
	  "positive and inexact"
	  "negative and exact"
	  "negative and inexact"))

(num-test 3/4)
   → "positive and exact"
(num-test -666)
   → "negative and exact"
(num-test -666.42)
   → "negative and inexact"
(num-test PI)
   → "positive and inexact"


Integer>>factors
	| a |
	a := OrderedCollection new.
	1 to: (self / 2) do: [ :i |
		((self \\ i) = 0) ifTrue: [ a add: i ] ].
	a add: self.
	^a


fun printIntList ls =
  (
    List.app (fn n => print(Int.toString n ^ " ")) ls;
    print "\n"
  );

fun factors n =
  let
    fun factors'(n, k) =
      if k > n then
        []
      else if n mod k = 0 then
        k :: factors'(n, k+1)
      else
        factors'(n, k+1)
  in
    factors'(n,1)
  end;


// Extend your language. Nigel Galloway: September 14th., 2021
type elsetf=TF
type elseft=FT
type elseff=FF
let elsetf,elseft,elseff=TF,FT,FF
let if2 n g tt (TF:elsetf)tf (FT:elseft)ft (FF:elseff)ff=match(n,g) with (true,true)->tt() |(true,false)->tf() |(false,true)->ft() |_->ff()
if2 (13<23) (23<42) (fun()->printfn "tt")
  elsetf (fun()->printfn "tf")
  elseft (fun()->printfn "ft")
  elseff (fun()->printfn "ff")
if2 (13<23) (42<23) (fun()->printfn "tt")
  elsetf (fun()->printfn "tf")
  elseft (fun()->printfn "ft")
  elseff (fun()->printfn "ff")
if2 (23<23) (23<42) (fun()->printfn "tt")
  elsetf (fun()->printfn "tf")
  elseft (fun()->printfn "ft")
  elseff (fun()->printfn "ff")
if2 (23<13) (42<23) (fun()->printfn "tt")
  elsetf (fun()->printfn "tf")
  elseft (fun()->printfn "ft")
  elseff (fun()->printfn "ff")


func factors(n: Int) -> [Int] {

    return filter(1...n) { n % $0 == 0 }
}


#
# snusp.icn, A Modular SNUSP interpreter
#

$define VERSION 0.6

# allow a couple of cli options
link options

# directions
$define DRIGHT 1
$define DLEFT  2
$define DUP    3
$define DDOWN  4

record position(row, col)
global dir, ip, ram

procedure main(argv)
   local ch, codespace, col, dp, fn, line
   local row := 1
   local wid := 0
   local dirs := []
   local ips := []
   local opts, verbose, debug

   opts := options(argv, "-h! -v! -d!", errorproc)
   \opts["v"] & verbose := 1
   \opts["h"] & show_help(verbose)
   \opts["d"] & debug := 1

   ip := position(1,1)

   # initial direction
   dir := DRIGHT

   # prepare initial memory
   ram := list(1, 0)

   # prepare code field
   codespace := []

   fn := open(argv[1], "r") | &input
   if (fn === &input) & \opts["h"] then return

   while line := read(fn) do {
      put(codespace, line)
      wid := max(*line, wid)
   }
   if *codespace = 0 then return
   every line := !codespace do {
      codespace[row] := left(codespace[row], wid)
      # track starting indicator
      if /col := find("$", codespace[row]) then {
         ip.row := row
         ip.col := col
      }
      row +:= 1
   }

   if \verbose then {
      write("Starting at ", ip.row, ", ", ip.col, " with codespace:")
      every write(!codespace)
   }

   dp := 1
   repeat {
      if not (ch := codespace[ip.row][ip.col]) then break
      if \debug then {
         write(&errout, "dir: ", dir, " ch: ", ch, " [", ord(ch), "]",
                        " row: ", ip.row, " col: ", ip.col,
                        " dp: ", dp, " ram[dp]: ", ram[dp])
      }
      case ch of {
         # six of the bf instructions
         "+": ram[dp] +:= 1
         "-": ram[dp] -:= 1
         ">": resize(dp +:= 1)
         "<": dp -:= 1
         ".": writes(char(ram[dp]) | char(0))
         ",": ram[dp] := getche()
         # direction change, LURD, RULD, SKIP, SKIPZ
         "\\": { # LURD
            case dir of {
               DRIGHT: dir := DDOWN
               DLEFT:  dir := DUP
               DUP:    dir := DLEFT
               DDOWN:  dir := DRIGHT
            }
         }
         "/": { # RULD
            case dir of {
               DRIGHT: dir := DUP
               DLEFT:  dir := DDOWN
               DUP:    dir := DRIGHT
               DDOWN:  dir := DLEFT
            }
         }
         "!": step()
         "?": { # skipz
            if ram[dp] = 0 then {
               step()
            }
         }
         # modular SNUSP
         "@": { # Enter
            push(dirs, dir)
            push(ips, copy(ip))
         }
         "#": { # Leave
            if *dirs < 1 then break
            dir := pop(dirs)
            ip := pop(ips)
            step()
         }
      }
      step()
   }
end

# advance the ip depending on direction
procedure step()
   case dir of {
      DRIGHT: ip.col +:= 1
      DLEFT:  ip.col -:= 1
      DUP:    ip.row -:= 1
      DDOWN:  ip.row +:= 1
   }
end

# enlarge memory when needed
procedure resize(elements)
   until *ram >= elements do put(ram, 0)
end

# quick help or verbose help
procedure show_help(verbose)
   write("SNUSP interpeter in Unicon, version ", VERSION)
   write("CORE and MODULAR, not yet BLOATED")
   write()
   write("Usage: unicon snusp.icn -x [filename] [-h|-v|-d]")
   write(" -h, help")
   write(" -v, verbose (and verbose help")
   write(" -d, debug (step tracer)")
   if \verbose then {
      write()
      write("Instructions:")
      write(" + INCR,  Increment current memory location")
      write(" - DECR,  Decrement current memory location")
      write(" > RIGHT, Advance memory pointer")
      write(" < LEFT,  Retreat memory pointer")
      write(" . WRITE, Output contents of current memory cell, in ASCII")
      write(" , READ,  Accept key and place byte value in current memory cell")
      write(" \\ LURD, If going:")
      write("           left,  go up")
      write("           up,    go left")
      write("           right, go down")
      write("           down,  go right")
      write(" / RULD, If going:")
      write("           right, go up")
      write("           up,    go right")
      write("           left,  go down")
      write("           down,  go left")
      write(" !, SKIP,  Move forward one step in current direction")
      write(" ?, SKIPZ, If current memory cell is zero then SKIP")
      write("Modular SNUSP adds:")
      write(" @, ENTER, Push direction and instruction pointer")
      write(" #, LEAVE, Pop direction and instruction pointer and SKIP")
      write()
      write("All other characters are NOOP, explicitly includes =,|,spc")
      write(" $, can set the starting location; first one found")
      write()
      write("Hello world examples:")
      write()
      write("CORE SNUSP:")
      write("/++++!/===========?\\>++.>+.+++++++..+++\\")
      write("\\+++\\ | /+>+++++++>/ /++++++++++<<.++>./")
      write("$+++/ | \\+++++++++>\\ \\+++++.>.+++.-----\\")
      write("      \\==-<<<<+>+++/ /=.>.+>.--------.-/")
      write()
      write("Modular SNUSP:")
      write("      /@@@@++++#               #[email protected]@\                #[email protected]@@\\n")
      write("[email protected]\\[email protected]/e.+++++++l.l.+++o.>>++++.< .<@/[email protected]\\[email protected]\\[email protected]\\d.>[email protected]/.#")
      write("  \\@@@@=>++++>+++++<<@+++++#       #[email protected]@/!=========/!==/")
      write()
   }
end


( scratchpad ) : 2ifte ( ..a ?0 ?1 quot0: ( ..a -- ..b ) quot1: ( ..a -- ..b ) quot2: ( ..a -- ..b ) quot3: ( ..a -- ..b ) -- ..b )
[ [ if ] curry curry ] [email protected] if ; inline
( scratchpad ) 3 [ 0 > ] [ even? ] bi [ 0 ] [ 1 ] [ 2 ] [ 3 ] 2ifte .
2


;; Fennel, being a Lisp, provides a way to define macros for new syntax.
;; The "`" and "," characters are used to construct a template for the macro.
(macro if2 [cond1 cond2 both first second none]
  `(if ,cond1
     (if ,cond2 ,both ,first)
     (if ,cond2 ,second ,none)))

(fn test-if2 [x y]
  (if2 x y
    (print "both")
    (print "first")
    (print "second")
    (print "none")))

(test-if2 true true)   ;"both"
(test-if2 true false)  ;"first"
(test-if2 false true)  ;"second"
(test-if2 false false) ;"none"


\ in this construct, either of the ELSE clauses may be omitted, just like IF-THEN.

: BOTH    postpone IF   postpone IF ; immediate
: ORELSE  postpone THEN postpone ELSE postpone IF ; immediate
: NEITHER postpone THEN postpone THEN ; immediate

: fb ( n -- )
  dup 5 mod 0=  over 3 mod 0=
  BOTH   ." FizzBuzz "
  ELSE   ." Fizz "
  ORELSE ." Buzz "
  ELSE   dup .
  NEITHER drop ;
: fizzbuzz ( n -- ) 0 do i 1+ fb loop ;


      LOGICAL A,B		!These are allocated the same storage
      INTEGER IA,IB		!As the default integer size.
      EQUIVALENCE (IA,A),(IB,B)	!So, this will cause no overlaps.

      WRITE (6,*) "Boolean tests via integers..."
      DO 199 IA = 0,1	!Two states for A.
        DO 199 IB = 0,1		!Two states for B.
          IF (IA) 666,99,109		!Not four ways, just three.
   99     IF (IB) 666,100,101		!Negative values are surely wrong.
  100     WRITE (6,*) "FF",IA,IB
          GO TO 199
  101     WRITE (6,*) "FT",IA,IB
          GO TO 199
  109     IF (IB) 666,110,111		!A second test.
  110     WRITE (6,*) "TF",IA,IB
          GO TO 199
  111     WRITE (6,*) "TT",IA,IB
  199 CONTINUE		!Both loops finish here.

      WRITE (6,*) "Boolean tests via integers and computed GO TO..."
      DO 299 IA = 0,1	!Two states for A.
        DO 299 IB = 0,1		!Two states for B.
          GO TO (200,201,210,211) 1 + IA*2 + IB	!Counting starts with one.
  200     WRITE (6,*) "FF",IA,IB
          GO TO 299
  201     WRITE (6,*) "FT",IA,IB
          GO TO 299
  210     WRITE (6,*) "TF",IA,IB
          GO TO 299
  211     WRITE (6,*) "TT",IA,IB
  299 CONTINUE		!Both loops finish here.

  300 WRITE (6,301)
  301 FORMAT (/,"Boolean tests via LOGICAL variables...",/
     1 " AB    IA    IB (IA*2 + IB)")
      A = .TRUE.	!Syncopation.
      B = .TRUE.	!Via the .NOT., the first pair will be FF.
      DO I = 0,1	!Step through two states.
        A = .NOT.A		!Thus generate F then T.
        DO J = 0,1		!Step through the second two states.
          B = .NOT.B			!Thus generate FF, FT, TF, TT.
          WRITE (6,302) A,B,IA,IB,IA*2 + IB	!But with strange values.
  302     FORMAT (1X,2L1,2I6,I8)		!Show both types.
        END DO			!Next value for B.
      END DO		!Next value for A.
      GO TO 999

  666 WRITE (6,*) "Huh?"

  999 CONTINUE
      END


: fib ( n -- fib )
  0 1 rot 0 ?do  over + swap  loop drop ;


proc factors {n} {
    set factors {}
    for {set i 1} {$i <= sqrt($n)} {incr i} {
        if {$n % $i == 0} {
            lappend factors $i [expr {$n / $i}]
        }
    }
    return [lsort -unique -integer $factors]
}
puts [factors 64]
puts [factors 45]
puts [factors 53]


factor() {
  r=`echo "sqrt($1)" | bc` # or `echo $1 v p | dc`
  i=1
  while [ $i -lt $r ]; do
    if [ `expr $1 % $i` -eq 0 ]; then
      echo $i
      expr $1 / $i
    fi
    i=`expr $i + 1`
  done | sort -nu
}


program fourWay(input, output, stdErr);
var
	tuple: record
			A: boolean;
			B: char;
		end;
begin
	tuple.A := true;
	tuple.B := 'Z';
	case tuple of
		(A: false; B: 'R'):
		begin
			writeLn('R is not good');
		end;
		(A: true; B: 'Z'):
		begin
			writeLn('Z is great');
		end;
		else
		begin
			writeLn('No');
		end;
	end;
end.


' FB 1.05.0 Win64

#Macro If2(condition1, condition2)
#Define Else1 ElseIf CBool(condition1) Then
#Define Else2 ElseIf CBool(condition2) Then
If CBool(condition1) AndAlso CBool(condition2) Then
#Endmacro

Sub test(a As Integer, b As Integer)
  If2(a > 0, b > 0)
    print "both positive"
  Else1
    print "first positive"
  Else2
    print "second positive"
  Else
    print "neither positive"
  End If
End Sub

Dim As Integer a, b
Print "a = 1, b = 1 => ";
test(1, 1)
Print "a = 1, b = 0 => ";
test(1, 0)
Print "a = 0, b = 1 => ";
test(0, 1)
Print "a = 0, b = 0 => ";
test(0, 0)
Print
Print "Press any key to quit"
Sleep


C     FIBONACCI SEQUENCE - FORTRAN IV
      NN=46
      DO 1 I=0,NN
    1 WRITE(*,300) I,IFIBO(I)
  300 FORMAT(1X,I2,1X,I10)
      END
C
      FUNCTION IFIBO(N)
      IF(N) 9,1,2
    1 IFN=0
      GOTO 9
    2 IF(N-1) 9,3,4
    3 IFN=1
      GOTO 9
    4 IFNM1=0
      IFN=1
      DO 5 I=2,N
      IFNM2=IFNM1
      IFNM1=IFN
    5 IFN=IFNM1+IFNM2
    9 IFIBO=IFN
      END


decl int n
set n (int args<1>)

decl int i
for (set i 1) (< i (+ (/ n 2) 1)) (inc i)
        if (= (mod n i) 0)
                out i "  " console
        end if
end for
out n endl console


#import std
#import nat

factors "n" = (filter not remainder/"n") nrange(1,"n")


-- Permutate a list according to a given factorial base number.
on FBNShuffle(|Ω|, fbn)
    set astid to AppleScript's text item delimiters
    set AppleScript's text item delimiters to "."
    set fbnDigits to fbn's text items
    set AppleScript's text item delimiters to astid

    repeat with m from 1 to (count fbnDigits)
        set m_plus_g to m + (item m of fbnDigits)
        set v to item m_plus_g of |Ω|
        repeat with i from (m_plus_g - 1) to m by -1
            set item (i + 1) of |Ω| to item i of |Ω|
        end repeat
        set item m of |Ω| to v
    end repeat
end FBNShuffle

-- Generate all the factorial base numbers having a given number of digits.
on generateFBNs(numberOfDigits)
    script o
        property partials : {}
        property permutations : {}
    end script

    if (numberOfDigits > 0) then
        repeat with i from 0 to numberOfDigits
            set end of o's permutations to (i as text)
        end repeat
        repeat with maxDigit from (numberOfDigits - 1) to 1 by -1
            set o's partials to o's permutations
            set o's permutations to {}
            repeat with i from 1 to (count o's partials)
                set thisPartial to item i of o's partials
                repeat with j from 0 to maxDigit
                    set end of o's permutations to (thisPartial & ("." & j))
                end repeat
            end repeat
        end repeat
    end if

    return o's permutations
end generateFBNs

-- Generate a random factorial base number having a given number of digits.
on generateRandomFBN(numberOfDigits)
    set fbnDigits to {}
    repeat with maxDigit from numberOfDigits to 1 by -1
        set end of fbnDigits to (random number maxDigit)
    end repeat

    set astid to AppleScript's text item delimiters
    set AppleScript's text item delimiters to "."
    set fbn to fbnDigits as text
    set AppleScript's text item delimiters to astid

    return fbn
end generateRandomFBN

(* Test code *)

set astid to AppleScript's text item delimiters
set AppleScript's text item delimiters to ""

-- 1. Reproduce table of {0, 1, 2, 3} permutations
set output to {"1. Reproduce table of {0, 1, 2, 3} permutations:"}
set elements to {0, 1, 2, 3}
set listOfFBNs to generateFBNs((count elements) - 1)
repeat with fbn in listOfFBNs
    copy elements to |Ω|
    FBNShuffle(|Ω|, fbn)
    set end of output to fbn's contents & " -> " & |Ω|
end repeat

-- 2. Generate and count all 11-digit permutations. No way!
set end of output to ""
set numberOfDigits to 11
set numberOfPermutations to 1
repeat with base from 2 to (numberOfDigits + 1)
    set numberOfPermutations to numberOfPermutations * base
end repeat
set end of output to "2. " & numberOfDigits & "-digit factorial base numbers have " & (numberOfPermutations div 1) & " possible permutations!"

-- 3. Card shoe permutations with the given FBNs.
set end of output to ""
set shoe to {"A♠", "K♠", "Q♠", "J♠", "10♠", "9♠", "8♠", "7♠", "6♠", "5♠", "4♠", "3♠", "2♠", ¬
    "A♥", "K♥", "Q♥", "J♥", "10♥", "9♥", "8♥", "7♥", "6♥", "5♥", "4♥", "3♥", "2♥", ¬
    "A♦", "K♦", "Q♦", "J♦", "10♦", "9♦", "8♦", "7♦", "6♦", "5♦", "4♦", "3♦", "2♦", ¬
    "A♣", "K♣", "Q♣", "J♣", "10♣", "9♣", "8♣", "7♣", "6♣", "5♣", "4♣", "3♣", "2♣"}
copy shoe to shoe1
copy shoe to shoe2
set fbn1 to "39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0"
set fbn2 to "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"
FBNShuffle(shoe1, fbn1)
FBNShuffle(shoe2, fbn2)
set end of output to "3. Shuffle " & shoe
set end of output to "With " & fbn1 & (linefeed & " -> " & shoe1)
set end of output to "With " & fbn2 & (linefeed & " -> " & shoe2)

-- 4. Card shoe permutation with randomly generated FBN.
set end of output to ""
set fbn3 to generateRandomFBN(51)
FBNShuffle(shoe, fbn3)
set end of output to "4. With randomly generated " & fbn3 & (linefeed & " -> " & shoe)

set AppleScript's text item delimiters to linefeed
set output to output as text
set AppleScript's text item delimiters to astid
return output


package main

import "fmt"

type F func()

type If2 struct {cond1, cond2 bool}

func (i If2) else1(f F) If2 {
    if i.cond1 && !i.cond2 {
        f()
    }
    return i
}

func (i If2) else2(f F) If2 {
    if i.cond2 && !i.cond1 {
        f()
    }
    return i
}

func (i If2) else0(f F) If2 {
    if !i.cond1 && !i.cond2 {
        f()
    }
    return i
}

func if2(cond1, cond2 bool, f F) If2 {
    if cond1 && cond2 {
        f()
    }
    return If2{cond1, cond2}
}

func main() {
    a, b := 0, 1
    if2 (a == 1, b == 3, func() {
        fmt.Println("a = 1 and b = 3")
    }).else1 (func() {
        fmt.Println("a = 1 and b <> 3")
    }).else2 (func() {
        fmt.Println("a <> 1 and b = 3")
    }).else0 (func() {
        fmt.Println("a <> 1 and b <> 3")
    })

    // It's also possible to omit any (or all) of the 'else' clauses or to call them out of order
    a, b = 1, 0
    if2 (a == 1, b == 3, func() {
        fmt.Println("a = 1 and b = 3")
    }).else0 (func() {
        fmt.Println("a <> 1 and b <> 3")
    }).else1 (func() {
        fmt.Println("a = 1 and b <> 3")
    })
}


type
	/// domain for Fibonacci function
	/// where result is within nativeUInt
	// You can not name it fibonacciDomain,
	// since the Fibonacci function itself
	// is defined for all whole numbers
	// but the result beyond F(n) exceeds high(nativeUInt).
	fibonacciLeftInverseRange =
		{$ifdef CPU64} 0..93 {$else} 0..47 {$endif};

{**
	implements Fibonacci sequence iteratively

	\param n the index of the Fibonacci number to calculate
	\returns the Fibonacci value at n
}
function fibonacci(const n: fibonacciLeftInverseRange): nativeUInt;
type
	/// more meaningful identifiers than simple integers
	relativePosition = (previous, current, next);
var
	/// temporary iterator variable
	i: longword;
	/// holds preceding fibonacci values
	f: array[relativePosition] of nativeUInt;
begin
	f[previous] := 0;
	f[current] := 1;

	// note, in Pascal for-loop-limits are inclusive
	for i := 1 to n do
	begin
		f[next] := f[previous] + f[current];
		f[previous] := f[current];
		f[current] := f[next];
	end;

	// assign to previous, bc f[current] = f[next] for next iteration
	fibonacci := f[previous];
end;


Function Factors(x As Integer) As String
 Application.Volatile
 Dim i As Integer
 Dim cooresponding_factors As String
 Factors = 1
 corresponding_factors = x
 For i = 2 To Sqr(x)
  If x Mod i = 0 Then
   Factors = Factors & ", " & i
   If i <> x / i Then corresponding_factors = x / i & ", " & corresponding_factors
  End If
 Next i
 If x <> 1 Then Factors = Factors & ", " & corresponding_factors
End Function


module main;
  integer i, n;

  initial begin
    n = 45;

    $write(n, " =>");
    for(i = 1; i <= n / 2; i = i + 1) if(n % i == 0) $write(i);
    $display(n);
    $finish ;
    end
endmodule


// Factorial base numbers indexing permutations of a collection
// Nigel Galloway: December 7th., 2018
let lN2p (c:int[]) (Ω:'Ω[])=
  let Ω=Array.copy Ω
  let rec fN i g e l=match l-i with 0->Ω.[i]<-e |_->Ω.[l]<-Ω.[l-1]; fN i g e (l-1)// rotate right
  [0..((Array.length Ω)-2)]|>List.iter(fun n->let i=c.[n] in if i>0 then fN n (i+n) Ω.[i+n] (i+n)); Ω
let lN n =
  let    Ω=(Array.length n)
  let fN g=if n.[g]=Ω-g then n.[g]<-0; false else n.[g]<-n.[g]+1; true
  seq{yield n; while [1..Ω]|>List.exists(fun g->fN (Ω-g)) do yield n}


USING: assocs io kernel literals math math.factorials
math.parser math.ranges prettyprint qw random sequences
splitting ;
RENAME: factoradic math.combinatorics.private => _factoradic
RENAME: rotate sequences.extras => _rotate
IN: rosetta-code.factorial-permutations

CONSTANT: shoe $[
    qw{ A K Q J 10 9 8 7 6 5 4 3 2 } qw{ ♠ ♥ ♦ ♣ }
    [ append ] cartesian-map flip concat
]

! Factor can already make factoradic numbers, but they always
! have a least-significant digit of 0 to remove.
: factoradic ( n -- seq )
    _factoradic dup [ drop but-last ] unless-empty ;

! Convert "3.1.2.0" to { 3 1 2 0 }, for example.
: string>factoradic ( str -- seq )
    "." split [ string>number ] map ;

! Rotate a subsequence.
! E.g. 0 2 { 3 1 2 0 } (rotate) -> { 2 3 1 0 }.
: (rotate) ( from to seq -- newseq )
    [ 1 + ] dip [ snip ] [ subseq ] 3bi -1 _rotate glue ;

! Only rotate a subsequence if from does not equal to.
: rotate ( from to seq -- newseq )
    2over = [ 2nip ] [ (rotate) ] if ;

! The pseudocode from the task description
: fpermute ( factoradic -- permutation )
    dup length 1 + <iota> swap <enumerated>
    [ over + rot rotate ] assoc-each ;

! Use a factoradic number to index permutations of a collection.
: findex ( factoradic seq -- permutation )
    [ fpermute ] [ nths concat ] bi* ;

: .f ( seq -- ) [ "." write ] [ pprint ] interleave ;   ! Print a factoradic number
: .p ( seq -- ) [ pprint ] each nl ;                    ! Print a permutation

: show-table ( -- )
    "Generate table" print 24
    [ factoradic 3 0 pad-head dup .f fpermute " -> " write .p ]
    each-integer nl ;

: show-shuffles ( -- )
    "Generate given task shuffles" print
    "Original deck:" print shoe concat print nl
    "39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0"
    "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"
    [ [ print ] [ string>factoradic shoe findex print nl ] bi ] [email protected] ;

: show-random-shuffle ( -- )
    "Random shuffle:" print
    51 52 [ n! ] [email protected] [a,b] random factoradic shoe findex print ;

: main ( -- ) show-table show-shuffles show-random-shuffle ;

MAIN: main


package main

import (
    "fmt"
    "math/rand"
    "strconv"
    "strings"
    "time"
)

func factorial(n int) int {
    fact := 1
    for i := 2; i <= n; i++ {
        fact *= i
    }
    return fact
}

func genFactBaseNums(size int, countOnly bool) ([][]int, int) {
    var results [][]int
    count := 0
    for n := 0; ; n++ {
        radix := 2
        var res []int = nil
        if !countOnly {
            res = make([]int, size)
        }
        k := n
        for k > 0 {
            div := k / radix
            rem := k % radix
            if !countOnly {
                if radix <= size+1 {
                    res[size-radix+1] = rem
                }
            }
            k = div
            radix++
        }
        if radix > size+2 {
            break
        }
        count++
        if !countOnly {
            results = append(results, res)
        }
    }
    return results, count
}

func mapToPerms(factNums [][]int) [][]int {
    var perms [][]int
    psize := len(factNums[0]) + 1
    start := make([]int, psize)
    for i := 0; i < psize; i++ {
        start[i] = i
    }
    for _, fn := range factNums {
        perm := make([]int, psize)
        copy(perm, start)
        for m := 0; m < len(fn); m++ {
            g := fn[m]
            if g == 0 {
                continue
            }
            first := m
            last := m + g
            for i := 1; i <= g; i++ {
                temp := perm[first]
                for j := first + 1; j <= last; j++ {
                    perm[j-1] = perm[j]
                }
                perm[last] = temp
            }
        }
        perms = append(perms, perm)
    }
    return perms
}

func join(is []int, sep string) string {
    ss := make([]string, len(is))
    for i := 0; i < len(is); i++ {
        ss[i] = strconv.Itoa(is[i])
    }
    return strings.Join(ss, sep)
}

func undot(s string) []int {
    ss := strings.Split(s, ".")
    is := make([]int, len(ss))
    for i := 0; i < len(ss); i++ {
        is[i], _ = strconv.Atoi(ss[i])
    }
    return is
}

func main() {
    rand.Seed(time.Now().UnixNano())

    // Recreate the table.
    factNums, _ := genFactBaseNums(3, false)
    perms := mapToPerms(factNums)
    for i, fn := range factNums {
        fmt.Printf("%v -> %v\n", join(fn, "."), join(perms[i], ""))
    }

    // Check that the number of perms generated is equal to 11! (this takes a while).
    _, count := genFactBaseNums(10, true)
    fmt.Println("\nPermutations generated =", count)
    fmt.Println("compared to 11! which  =", factorial(11))
    fmt.Println()

    // Generate shuffles for the 2 given 51 digit factorial base numbers.
    fbn51s := []string{
        "39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0",
        "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1",
    }
    factNums = [][]int{undot(fbn51s[0]), undot(fbn51s[1])}
    perms = mapToPerms(factNums)
    shoe := []rune("A♠K♠Q♠J♠T♠9♠8♠7♠6♠5♠4♠3♠2♠A♥K♥Q♥J♥T♥9♥8♥7♥6♥5♥4♥3♥2♥A♦K♦Q♦J♦T♦9♦8♦7♦6♦5♦4♦3♦2♦A♣K♣Q♣J♣T♣9♣8♣7♣6♣5♣4♣3♣2♣")
    cards := make([]string, 52)
    for i := 0; i < 52; i++ {
        cards[i] = string(shoe[2*i : 2*i+2])
        if cards[i][0] == 'T' {
            cards[i] = "10" + cards[i][1:]
        }
    }
    for i, fbn51 := range fbn51s {
        fmt.Println(fbn51)
        for _, d := range perms[i] {
            fmt.Print(cards[d])
        }
        fmt.Println("\n")
    }

    // Create a random 51 digit factorial base number and produce a shuffle from that.
    fbn51 := make([]int, 51)
    for i := 0; i < 51; i++ {
        fbn51[i] = rand.Intn(52 - i)
    }
    fmt.Println(join(fbn51, "."))
    perms = mapToPerms([][]int{fbn51})
    for _, d := range perms[0] {
        fmt.Print(cards[d])
    }
    fmt.Println()
}


#
# snusp.icn, A Modular SNUSP interpreter
#

$define VERSION 0.6

# allow a couple of cli options
link options

# directions
$define DRIGHT 1
$define DLEFT  2
$define DUP    3
$define DDOWN  4

record position(row, col)
global dir, ip, ram

procedure main(argv)
   local ch, codespace, col, dp, fn, line
   local row := 1
   local wid := 0
   local dirs := []
   local ips := []
   local opts, verbose, debug

   opts := options(argv, "-h! -v! -d!", errorproc)
   \opts["v"] & verbose := 1
   \opts["h"] & show_help(verbose)
   \opts["d"] & debug := 1

   ip := position(1,1)

   # initial direction
   dir := DRIGHT

   # prepare initial memory
   ram := list(1, 0)

   # prepare code field
   codespace := []

   fn := open(argv[1], "r") | &input
   if (fn === &input) & \opts["h"] then return

   while line := read(fn) do {
      put(codespace, line)
      wid := max(*line, wid)
   }
   if *codespace = 0 then return
   every line := !codespace do {
      codespace[row] := left(codespace[row], wid)
      # track starting indicator
      if /col := find("$", codespace[row]) then {
         ip.row := row
         ip.col := col
      }
      row +:= 1
   }

   if \verbose then {
      write("Starting at ", ip.row, ", ", ip.col, " with codespace:")
      every write(!codespace)
   }

   dp := 1
   repeat {
      if not (ch := codespace[ip.row][ip.col]) then break
      if \debug then {
         write(&errout, "dir: ", dir, " ch: ", ch, " [", ord(ch), "]",
                        " row: ", ip.row, " col: ", ip.col,
                        " dp: ", dp, " ram[dp]: ", ram[dp])
      }
      case ch of {
         # six of the bf instructions
         "+": ram[dp] +:= 1
         "-": ram[dp] -:= 1
         ">": resize(dp +:= 1)
         "<": dp -:= 1
         ".": writes(char(ram[dp]) | char(0))
         ",": ram[dp] := getche()
         # direction change, LURD, RULD, SKIP, SKIPZ
         "\\": { # LURD
            case dir of {
               DRIGHT: dir := DDOWN
               DLEFT:  dir := DUP
               DUP:    dir := DLEFT
               DDOWN:  dir := DRIGHT
            }
         }
         "/": { # RULD
            case dir of {
               DRIGHT: dir := DUP
               DLEFT:  dir := DDOWN
               DUP:    dir := DRIGHT
               DDOWN:  dir := DLEFT
            }
         }
         "!": step()
         "?": { # skipz
            if ram[dp] = 0 then {
               step()
            }
         }
         # modular SNUSP
         "@": { # Enter
            push(dirs, dir)
            push(ips, copy(ip))
         }
         "#": { # Leave
            if *dirs < 1 then break
            dir := pop(dirs)
            ip := pop(ips)
            step()
         }
      }
      step()
   }
end

# advance the ip depending on direction
procedure step()
   case dir of {
      DRIGHT: ip.col +:= 1
      DLEFT:  ip.col -:= 1
      DUP:    ip.row -:= 1
      DDOWN:  ip.row +:= 1
   }
end

# enlarge memory when needed
procedure resize(elements)
   until *ram >= elements do put(ram, 0)
end

# quick help or verbose help
procedure show_help(verbose)
   write("SNUSP interpeter in Unicon, version ", VERSION)
   write("CORE and MODULAR, not yet BLOATED")
   write()
   write("Usage: unicon snusp.icn -x [filename] [-h|-v|-d]")
   write(" -h, help")
   write(" -v, verbose (and verbose help")
   write(" -d, debug (step tracer)")
   if \verbose then {
      write()
      write("Instructions:")
      write(" + INCR,  Increment current memory location")
      write(" - DECR,  Decrement current memory location")
      write(" > RIGHT, Advance memory pointer")
      write(" < LEFT,  Retreat memory pointer")
      write(" . WRITE, Output contents of current memory cell, in ASCII")
      write(" , READ,  Accept key and place byte value in current memory cell")
      write(" \\ LURD, If going:")
      write("           left,  go up")
      write("           up,    go left")
      write("           right, go down")
      write("           down,  go right")
      write(" / RULD, If going:")
      write("           right, go up")
      write("           up,    go right")
      write("           left,  go down")
      write("           down,  go left")
      write(" !, SKIP,  Move forward one step in current direction")
      write(" ?, SKIPZ, If current memory cell is zero then SKIP")
      write("Modular SNUSP adds:")
      write(" @, ENTER, Push direction and instruction pointer")
      write(" #, LEAVE, Pop direction and instruction pointer and SKIP")
      write()
      write("All other characters are NOOP, explicitly includes =,|,spc")
      write(" $, can set the starting location; first one found")
      write()
      write("Hello world examples:")
      write()
      write("CORE SNUSP:")
      write("/++++!/===========?\\>++.>+.+++++++..+++\\")
      write("\\+++\\ | /+>+++++++>/ /++++++++++<<.++>./")
      write("$+++/ | \\+++++++++>\\ \\+++++.>.+++.-----\\")
      write("      \\==-<<<<+>+++/ /=.>.+>.--------.-/")
      write()
      write("Modular SNUSP:")
      write("      /@@@@++++#               #[email protected]@\                #[email protected]@@\\n")
      write("[email protected]\\[email protected]/e.+++++++l.l.+++o.>>++++.< .<@/[email protected]\\[email protected]\\[email protected]\\d.>[email protected]/.#")
      write("  \\@@@@=>++++>+++++<<@+++++#       #[email protected]@/!=========/!==/")
      write()
   }
end


if2 :: Bool -> Bool -> a -> a -> a -> a -> a
if2 p1 p2 e12 e1 e2 e =
  if p1 then
    if p2 then e12 else e1
    else if p2 then e2 else e

main = print $ if2 True False (error "TT") "TF" (error "FT") (error "FF")


procedure main(A)
    if2 { (A[1] = A[2]), (A[3] = A[4]),   # Use PDCO with all three else clauses
          write("1: both true"),
          write("1: only first true"),
          write("1: only second true"),
          write("1: neither true")
        }
    if2 { (A[1] = A[2]), (A[3] = A[4]),    # Use same PDCO with only one else clause
          write("2: both true"),
          write("2: only first true"),
        }
end

procedure if2(A)		# The double-conditional PDCO
    suspend if @A[1] then
        if @A[2] then |@A[3]    # Run-err if missing 'then' clause
        else @\A[4]	        # (all else clauses are optional)
    else if @A[2] then |@\A[5]
    else |@\A[6]
end


'Fibonacci extended
'Freebasic version 24  Windows
Dim Shared ADDQmod(0 To 19) As Ubyte
Dim Shared ADDbool(0 To 19) As Ubyte

For z As Integer=0 To 19
    ADDQmod(z)=(z Mod 10+48)
    ADDbool(z)=(-(10<=z))
Next z

Function plusINT(NUM1 As String,NUM2 As String) As String
    Dim As Byte flag
    #macro finish()
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If flag=1 Then Swap NUM2,NUM1
    Return three
    Exit Function
    #endmacro
    var lenf=Len(NUM1)
    var lens=Len(NUM2)
    If lens>lenf Then
        Swap NUM2,NUM1
        Swap lens,lenf
        flag=1
    End If

    var diff=lenf-lens-Sgn(lenf-lens)
    var three="0"+NUM1
    var two=String(lenf-lens,"0")+NUM2
    Dim As Integer n2
    Dim As Ubyte addup,addcarry

    addcarry=0

    For n2=lenf-1 To diff Step -1
        addup=two[n2]+NUM1[n2]-96
        three[n2+1]=addQmod(addup+addcarry)
        addcarry=addbool(addup+addcarry)
    Next n2
    If addcarry=0 Then
        finish()
    End If
    If n2=-1 Then
        three[0]=addcarry+48
        finish()
    End If

    For n2=n2 To 0 Step -1
        addup=two[n2]+NUM1[n2]-96
        three[n2+1]=addQmod(addup+addcarry)
        addcarry=addbool(addup+addcarry)
    Next n2
    three[0]=addcarry+48
    finish()
End Function

Function  fibonacci(n As Integer) As String
    Dim As String sl,l,term
    sl="0": l="1"
    If n=1 Then Return "0"
    If n=2 Then Return "1"
    n=n-2
    For x As Integer= 1 To n
        term=plusINT(l,sl)
        sl=l
        l=term
    Next x
    Function =term
End Function

'==============  EXAMPLE ===============
print "THE SEQUENCE TO 10:"
print
For n As Integer=1 To 10
    Print "term";n;": "; fibonacci(n)
Next n
print
print "Selected Fibonacci number"
print "Fibonacci 500"
print
print fibonacci(500)
Sleep


@let {
  factors1      &n !-\%%n @to n
  factors_tacit @(\\%% !- @to)
  [[
    !factors1 10
    !factors_tacit 100
    !factors1 720
  ]]
}


import "/fmt" for Fmt
import "/math" for Int

var a = [11, 21, 32, 45, 67, 96, 159, 723, 1024, 5673, 12345, 32767, 123459, 999997]
System.print("The factors of the following numbers are:")
for (e in a) System.print("%(Fmt.d(6, e)) => %(Int.divisors(e))")


import Data.List (unfoldr, intercalate)

newtype Fact = Fact [Int]

-- smart constructor
fact :: [Int] -> Fact
fact = Fact . zipWith min [0..] . reverse

instance Show Fact where
  show (Fact ds) = intercalate "." $ show <$> reverse ds

toFact :: Integer -> Fact
toFact 0 = Fact [0]
toFact n = Fact $ unfoldr f (1, n)
  where
    f (b, 0) = Nothing
    f (b, n) = let (q, r) = n `divMod` b
               in Just (fromIntegral r, (b+1, q))

fromFact :: Fact -> Integer
fromFact (Fact ds) = foldr f 0 $ zip [1..] ds
  where
    f (b, d) r = r * b + fromIntegral d


function makefactorialbased(N, makelist)
    listlist = Vector{Vector{Int}}()
    count = 0
    while true
        divisor = 2
        makelist && (lis = zeros(Int, N))
        k = count
        while k > 0
            k, r = divrem(k, divisor)
            makelist && (divisor <= N + 1) && (lis[N - divisor + 2] = r)
            divisor += 1
        end
        if divisor > N + 2
            break
        end
        count += 1
        makelist && push!(listlist, lis)
    end
    return count, listlist
end

function facmap(factnumbase)
    perm = [i for i in 0:length(factnumbase)]
    for (n, g) in enumerate(factnumbase)
        if g != 0
            perm[n:n + g] .= circshift(perm[n:n + g], 1)
        end
    end
    perm
end

function factbasenums()
    fcount, factnums = makefactorialbased(3, true)
    perms = map(facmap, factnums)
    for (i, fn) = enumerate(factnums)
        println("$(join(string.(fn), ".")) -> $(join(string(perms[i]), ""))")
    end

    fcount, _ = makefactorialbased(10, false)
    println("\nPermutations generated = $fcount, and 11! = $(factorial(11))\n")

    taskrandom = ["39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0",
        "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"]
    perms = map(s -> facmap([parse(Int, s) for s in split(s, ".")]), taskrandom)

    cardshoe = split("A♠K♠Q♠J♠T♠9♠8♠7♠6♠5♠4♠3♠2♠A♥K♥Q♥J♥T♥9♥8♥7♥6♥5♥4♥3♥2♥A♦K♦Q♦J♦T♦9♦8♦7♦6♦5♦4♦3♦2♦A♣K♣Q♣J♣T♣9♣8♣7♣6♣5♣4♣3♣2♣", "")
    cards = [cardshoe[2*i+1] * cardshoe[2*i+2] for i in 0:51]
    printcardshuffle(t, c, o) = (println(t); for i in 1:length(o) print(c[o[i] + 1]) end; println())

    println("\nTask shuffles:")
    map(i -> printcardshuffle(taskrandom[i], cards, perms[i]), 1:2)

    myran = [rand(collect(0:i)) for i in 51:-1:1]
    perm = facmap(myran)
    println("\nMy random shuffle:")
    printcardshuffle(join(string.(myran), "."), cards, perm)
end

factbasenums()


import algorithm, math, random, sequtils, strutils, unicode

# Representation of a factorial base number with N digits.
type FactorialBaseNumber[N: static Positive] = array[N, int]

#---------------------------------------------------------------------------------------------------

func permutation[T](elements: openArray[T]; n: FactorialBaseNumber): seq[T] =
  ## Return the permutation of "elements" associated to the factorial base number "n".
  result = @elements
  for m, g in n:
    if g > 0:
      result.rotateLeft(m.int..(m + g), -1)

#---------------------------------------------------------------------------------------------------

func incr(n: var FactorialBaseNumber): bool =
  ## Increment a factorial base number.
  ## Return false if an overflow occurred.
  var base = 1
  var k = 1
  for i in countdown(n.high, 0):
    inc base
    inc n[i], k
    if n[i] >= base:
      n[i] = 0
      k = 1
    else:
      k = 0
  result = k == 0

#---------------------------------------------------------------------------------------------------

iterator fbnSeq(n: static Positive): auto =
  ## Yield the successive factorial base numbers of length "n".
  var result: FactorialBaseNumber[n]
  while true:
    yield result
    if not incr(result): break

#---------------------------------------------------------------------------------------------------

func `$`(n: FactorialBaseNumber): string {.inline.} =
  ## Return the string representation of a factorial base number.
  n.join(".")

#———————————————————————————————————————————————————————————————————————————————————————————————————

# Part 1.
echo "Mapping between factorial base numbers and permutations:"
for n in fbnSeq(3):
  echo n, " → ", "0123".permutation(n).join()

# Part 2.
echo ""
echo "Generating the permutations of 11 digits:"
const Target = fac(11)
var count = 0
for n in fbnSeq(10):
  inc count
  let perm = "0123456789A".permutation(n)
  if count in 1..3 or count in (Target - 2)..Target:
    echo n, " → ", perm.join()
  elif count == 4:
    echo "[...]"
echo "Number of permutations generated: ", count
echo "Number of permutations expected:  ", Target

# Part 3.
const
  FBNS = [
    "39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0",
    "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"]
  Cards = ["A♠", "K♠", "Q♠", "J♠", "10♠", "9♠", "8♠", "7♠", "6♠", "5♠", "4♠", "3♠", "2♠",
           "A♥", "K♥", "Q♥", "J♥", "10♥", "9♥", "8♥", "7♥", "6♥", "5♥", "4♥", "3♥", "2♥",
           "A♦", "K♦", "Q♦", "J♦", "10♦", "9♦", "8♦", "7♦", "6♦", "5♦", "4♦", "3♦", "2♦",
           "A♣", "K♣", "Q♣", "J♣", "10♣", "9♣", "8♣", "7♣", "6♣", "5♣", "4♣", "3♣", "2♣"]
  M = Cards.len - 1

var fbns: array[3, FactorialBaseNumber[M]]

# Parse the given factorial base numbers.
for i in 0..1:
  for j, n in map(FBNS[i].split('.'), parseInt):
    fbns[i][j] = n

# Generate a random factorial base number.
randomize()
for j in 0..fbns[3].high:
  fbns[2][j] = rand(0..(M - j))

echo ""
echo "Card permutations:"
for i in 0..2:
  echo "– for ", fbns[i], ':'
  echo "  ", Cards.permutation(fbns[i]).join(" ")


Note 'snusp'

    Without $ character the program counter starts at top left (0 0) moving to the right (0 1)

    >       increment the pointer (to point to the next cell to the right).
    <       decrement the pointer (to point to the next cell to the left).
    +       increment (increase by one) the cell at the pointer.
    -       decrement (decrease by one) the cell at the pointer.
    .       output the value of the cell at the pointer as a character.
    ,       accept one character of input, storing its value in the cell at the pointer.
    \/      mirrors
    ?       skip if memory pointer is 0
    !       skip
    $       optional start program here (also heading to the right)

)

smoutput 'Toroidal programs run forever.  Use ^C to interrupt.'

main =: 3 : 0  NB. use: main 'program.snusp'
 PROGRAM =: [;._2 LF ,~ 1!:1 boxopen y
 SHAPE =: $PROGRAM
 PC =: SHAPE#:(,PROGRAM) i.'$'
 PCSTEP =: 0 1
 CELL =: 0
 CELLS =: ,0
 while. 1 do. NB. for_i. i.400 do.
  INSTRUCTION =: (<PC) { PROGRAM
  STEP =: PCSTEP
  select. INSTRUCTION
  case. '<' do.
   CELL =: <: CELL
   if. CELL < 0 do.
    CELL =: 0
    CELLS =: 0 , CELLS
   end.
  case. '>' do.
   CELL =: >: CELL
   if. CELL >: # CELLS do.
    CELLS =: CELLS , 0
   end.
  case. ;/'-+' do. CELLS =: CELL ((<:'- +'i.INSTRUCTION)+{)`[`]} CELLS
  case. '.' do. 1!:2&4 (CELL{CELLS){a.
  case. ',' do. CELLS =: (1!:1<1) CELL } CELLS
  fcase. '/' do. STEP =: - STEP
  case. '\' do. STEP =: PCSTEP =: |. STEP
  case. '?' do. STEP =: +:^:(0 = CELL{CELLS) STEP
  case. '!' do. STEP =: +: STEP
  end.
  PC =: (| (PC + STEP + ])) SHAPE  NB. toroidal
  NB. smoutput PC;CELL;CELLS  NB. debug
 end.
)


const echo2 =  raw"""
       /==!/======ECHO==,==.==#
       |   |
$==>[email protected]/[email protected]/==<==#"""

@enum Direction left up right down

function snusp(datalength, progstring)
    stack = Vector{Tuple{Int, Int, Direction}}()
    data = zeros(datalength)
    dp = ipx = ipy = 1
    direction = right    # default to go to right at beginning

    lines = split(progstring, "\n")
    lmax = maximum(map(length, lines))
    lines = map(x -> rpad(x, lmax), lines)
    for (y, li) in enumerate(lines)
        if (x = findfirst("\$", li)) != nothing
            (ipx, ipy) = (x[1], y)
        end
    end

    instruction = Dict([('>', ()-> dp += 1),
        ('<', ()-> (dp -= 1; if dp < 0 running = false end)), ('+', ()-> data[dp] += 1),
        ('-', ()-> data[dp] -= 1), (',', ()-> (data[dp] = read(stdin, UInt8))),
        ('.', ()->print(Char(data[dp]))),
        ('/', ()-> (d = Int(direction); d += (iseven(d) ? 3 : 5); direction = Direction(d % 4))),
        ('\\', ()-> (d = Int(direction); d += (iseven(d) ? 1 : -1); direction = Direction(d))),
        ('!', () -> ipnext()), ('?', ()-> if data[dp] == 0 ipnext() end),
        ('@', ()-> push!(stack, (ipx, ipy, direction))),
        ('#', ()-> if length(stack) > 0 (ipx, ipy, direction) = pop!(stack) end),
        ('\n', ()-> (running = false))])

    inboundsx(plus) = (plus ? (ipx < lmax) : (ipx > 1)) ? true : exit(data[dp])
    inboundsy(plus) = (plus ? (ipy < length(lines)) : (ipy > 1)) ? true : exit(data[dp])
    function ipnext()
        if direction == right && inboundsx(true)     ipx += 1
        elseif direction == left && inboundsx(false) ipx -= 1
        elseif direction == down && inboundsy(true)  ipy += 1
        elseif direction == up && inboundsy(false)   ipy -= 1
        end
    end

    running = true
    while running
        cmdcode = lines[ipy][ipx]
        if haskey(instruction, cmdcode)
            instruction[cmdcode]()
        end
        ipnext()
    end
    exit(data[dp])
end

snusp(100, echo2)


// version 1.1.2

// requires 5 chars (10 bytes) of data store
const val hw = """
/++++!/===========?\>++.>+.+++++++..+++\
\+++\ | /+>+++++++>/ /++++++++++<<.++>./
$+++/ | \+++++++++>\ \+++++.>.+++.-----\
      \==-<<<<+>+++/ /=.>.+>.--------.-/"""

// input is a multi-line string.
fun snusp(dlen: Int, raw: String) {
    val ds = CharArray(dlen)  // data store
    var dp = 0                // data pointer
    var s = raw

    // remove leading '\n' from string if present
    s = s.trimStart('\n')

    // make 2 dimensional instruction store and declare instruction pointers
    val cs = s.split('\n')
    var ipr = 0
    var ipc = 0

    // look for starting instruction
    findStart@  for ((r, row) in cs.withIndex()) {
        for ((i, c) in row.withIndex()) {
            if (c == '$') {
                ipr = r
                ipc = i
                break@findStart
            }
        }
    }

    var id = 0
    val step = fun() {
        if (id and 1 == 0)
            ipc += 1 - (id and 2)
        else
            ipr += 1 - (id and 2)
    }

    // execute
    while ((ipr in 0 until cs.size) && (ipc in 0 until cs[ipr].length)) {
        when (cs[ipr][ipc]) {
            '>'  -> dp++
            '<'  -> dp--
            '+'  -> ds[dp]++
            '-'  -> ds[dp]--
            '.'  -> print(ds[dp])
            ','  -> ds[dp] = readLine()!![0]
            '/'  -> id = id.inv()
            '\\' -> id = id xor 1
            '!'  -> step()
            '?'  -> if (ds[dp] == '\u0000') step()
        }
        step()
    }
}

fun main(args: Array<String>) {
    snusp(5, hw)
}


if2 : Bool -> Bool -> Lazy a -> Lazy a -> Lazy a -> Lazy a -> a
if2 True True  v _ _ _ = v
if2 True False _ v _ _ = v
if2 False True _ _ v _ = v
if2 _     _    _ _ _ v = v


To if2 (c1 - condition) and-or (c2 - condition) begin -- end: (- switch (({c1})*2 + ({c2})) { 3: do -).
To else1 -- in if2: (- } until (1); 2: do { -).
To else2 -- in if2: (- } until (1); 1: do { -).
To else0 -- in if2: (- } until (1); 0: -).


fibonacciN[n] :=
{
   a = 0
   b = 1
   count = 0
   while count < n
   {
      [a,b] = [b, a + b]
      count = count + 1
   }
   return a
}


section .bss
    factorArr resd 250 ;big buffer against seg fault

section .text
global _main
_main:
    mov ebp, esp; for correct debugging
    mov eax, 0x7ffffffe ;number of which we want to know the factors, max num this program works with
    mov ebx, eax ;save eax
    mov ecx, 1 ;n, factor we test for
    mov [factorArr], dword 0
    looping:
        mov eax, ebx ;restore eax
        xor edx, edx ;clear edx
        div ecx
        cmp edx, 0 ;test if our number % n == 0
        jne next
        mov edx, [factorArr] ;if yes, we increment the size of the array and append n
        inc edx
        mov [factorArr+edx*4], ecx ;appending n
        mov [factorArr], edx ;storing the new size
    next:
        mov eax, ecx
        cmp eax, ebx ;is n bigger then our number ?
        jg end ;if yes we end
        inc ecx
        jmp looping
    end:
        mov ecx, factorArr ;pass arr address by ecx
        xor eax, eax ;clear eax
        mov esp, ebp ;garbage collecting
        ret


import strutils

# Requires 5 bytes of data store.
const Hw = r"""
/++++!/===========?\>++.>+.+++++++..+++\
\+++\ | /+>+++++++>/ /++++++++++<<.++>./
$+++/ | \+++++++++>\ \+++++.>.+++.-----\
      \==-<<<<+>+++/ /=.>.+>.--------.-/"""

#---------------------------------------------------------------------------------------------------

proc snusp(dsLen: int; code: string) =
  ## The interpreter.

  var
    ds = newSeq[byte](dsLen)  # Data store.
    dp = 0                    # Data pointer.
    cs = code.splitLines()    # Two dimensional code store.
    ipr, ipc = 0              # Instruction pointers in row ans column.
    dir = 0                   # Direction (0 = right, 1 = down, 2 = left, 3 = up).

  # Initialize instruction pointers.
  for r, row in cs:
    ipc = row.find('$')
    if ipc >= 0:
      ipr = r
      break

  #.................................................................................................

  func step() =
    ## Update the instruction pointers acccording to the direction.

    if (dir and 1) == 0:
      inc ipc, 1 - (dir and 2)
    else:
      inc ipr, 1 - (dir and 2)

  #.................................................................................................

  # Interpreter loop.
  while ipr in 0..cs.high and ipc in 0..cs[ipr].high:
    case cs[ipr][ipc]
    of '>': inc dp
    of '<': dec dp
    of '+': inc ds[dp]
    of '-': dec ds[dp]
    of '.': stdout.write chr(ds[dp])
    of ',': ds[dp] = byte(stdin.readLine()[0])
    of '/': dir = not dir
    of '\\': dir = dir xor 1
    of '!': step()
    of '?': (if ds[dp] == 0: step())
    else: discard
    step()

#———————————————————————————————————————————————————————————————————————————————————————————————————

when isMainModule:
  snusp(5, Hw)


with javascript_semantics
integer id = 0, ipr = 1, ipc = 1

procedure step()
    if and_bits(id,1) == 0 then
        ipc += 1 - and_bits(id,2)
    else
        ipr += 1 - and_bits(id,2)
    end if
end procedure

procedure snusp(integer dlen, string s)
    sequence ds = repeat(0,dlen)  -- data store
    integer dp = 1                -- data pointer

    -- remove leading '\n' from string if present
    s = trim_head(s,'\n')

    -- make 2 dimensional instruction store and set instruction pointers
    sequence cs = split(s,'\n')
    ipr = 1
    ipc = 1

    -- look for starting instruction
    for i=1 to length(cs) do
        ipc = find('$',cs[i])
        if ipc then
            ipr = i
            exit
        end if
    end for

    id = 0

    -- execute
    while ipr>=1 and ipr<=length(cs)
      and ipc>=1 and ipc<=length(cs[ipr]) do
        integer op = cs[ipr][ipc]
        switch op do
            case '>' : dp += 1
            case '<' : dp -= 1
            case '+' : ds[dp] += 1
            case '-' : ds[dp] -= 1
            case '.' : puts(1,ds[dp])
            case ',' : ds[dp] = getc(0)
            case '/' : id = not_bits(id)
            case '\\': id = xor_bits(id,1)
            case '!' : step()
            case '?' : if ds[dp]=0 then step() end if
        end switch
        step()
    end while
end procedure

constant hw = """
/++++!/===========?\>++.>+.+++++++..+++\
\+++\ | /+>+++++++>/ /++++++++++<<.++>./
$+++/ | \+++++++++>\ \+++++.>.+++.-----\
      \==-<<<<+>+++/ /=.>.+>.--------.-/"""

snusp(5, hw)


public class If2 {

    public static void if2(boolean firstCondition, boolean secondCondition,
                           Runnable bothTrue, Runnable firstTrue, Runnable secondTrue, Runnable noneTrue) {
        if (firstCondition)
            if (secondCondition)
                bothTrue.run();
            else firstTrue.run();
        else if (secondCondition)
            secondTrue.run();
        else noneTrue.run();
    }
}


const CSTACK1 = Array{Bool,1}()
const CSTACK2 = Array{Bool,1}()
const CSTACK3 = Array{Bool,1}()

macro if2(condition1, condition2, alltrue)
    if !(length(CSTACK1) == length(CSTACK2) == length(CSTACK3))
        throw("prior if2 statement error: must have if2, elseif1, elseif2, and elseifneither")
    end
    ifcond1 = eval(condition1)
    ifcond2 = eval(condition2)
    if ifcond1 && ifcond2
        eval(alltrue)
        push!(CSTACK1, false)
        push!(CSTACK2, false)
        push!(CSTACK3, false)
    elseif ifcond1
        push!(CSTACK1, true)
        push!(CSTACK2, false)
        push!(CSTACK3, false)
    elseif ifcond2
        push!(CSTACK1, false)
        push!(CSTACK2, true)
        push!(CSTACK3, false)
    else
        push!(CSTACK1, false)
        push!(CSTACK2, false)
        push!(CSTACK3, true)
    end
end

macro elseif1(block)
    quote
        if pop!(CSTACK1)
            $block
        end
    end
end

macro elseif2(block)
    quote
        if pop!(CSTACK2)
            $block
        end
    end
end

macro elseifneither(block)
    quote
        if pop!(CSTACK3)
            $block
        end
    end
end

# Testing of code starts here

@if2(2 != 4, 3 != 7, begin x = "all"; println(x) end)

@elseif1(begin println("one") end)

@elseif2(begin println("two") end)

@elseifneither(begin println("neither") end)

@if2(2 != 4, 3 == 7, println("all"))

@elseif1(begin println("one") end)

@elseif2(begin println("two") end)

@elseifneither(begin println("neither") end)

@if2(2 == 4, 3 != 7, begin x = "all"; println(x) end)

@elseif1(begin println("one") end)

@elseif2(begin println("two") end)

@elseifneither(begin println("neither") end)

@if2(2 == 4, 3 == 7, println("last all") end)

@elseif1(begin println("one") end)

@elseif2(begin println("two") end)

@elseifneither(begin println("neither") end)


// version 1.0.6

data class IfBoth(val cond1: Boolean, val cond2: Boolean) {
    fun elseFirst(func: () -> Unit): IfBoth {
        if (cond1 && !cond2) func()
        return this
    }

    fun elseSecond(func: () -> Unit): IfBoth {
        if (cond2 && !cond1) func()
        return this
    }

    fun elseNeither(func: () -> Unit): IfBoth {
        if (!cond1 && !cond2) func()
        return this  // in case it's called out of order
    }
}

fun ifBoth(cond1: Boolean, cond2: Boolean, func: () -> Unit): IfBoth {
    if (cond1 && cond2) func()
    return IfBoth(cond1, cond2)
}

fun main(args: Array<String>) {
    var a = 0
    var b = 1
    ifBoth (a == 1, b == 3) {
        println("a = 1 and b = 3")
    }
    .elseFirst {
        println("a = 1 and b <> 3")
    }
    .elseSecond {
        println("a <> 1 and b = 3")
    }
    .elseNeither {
        println("a <> 1 and b <> 3")
    }

    // It's also possible to omit any (or all) of the 'else' clauses or to call them out of order
    a = 1
    b = 0
    ifBoth (a == 1, b == 3) {
        println("a = 1 and b = 3")
    }
    .elseNeither {
        println("a <> 1 and b <> 3")
    }
    .elseFirst {
        println("a = 1 and b <> 3")
    }
}


FIBONACCI   PUSH   R1
            PUSH   R2
            PUSH   R3

            MOVE   0,  R1
            MOVE   1,  R2

FIB_LOOP    SUB    R0,  1, R0
            JP_Z   FIB_DONE

            MOVE   R2, R3
            ADD    R1, R2, R2
            MOVE   R3, R1

            JP     FIB_LOOP

FIB_DONE    MOVE   R2, R0

            POP    R3
            POP    R2
            POP    R1

            RET


include c:\cxpl\codes;
int     N0, N, F;
[N0:= 1;
repeat  IntOut(0, N0);  Text(0, " = ");
        F:= 2;  N:= N0;
        repeat  if rem(N/F) = 0 then
                        [if N # N0 then Text(0, " * ");
                        IntOut(0, F);
                        N:= N/F;
                        ]
                else F:= F+1;
        until   F>N;
        if N0=1 then IntOut(0, 1);      \1 = 1
        CrLf(0);
        N0:= N0+1;
until   KeyHit;
]


sub printFactors(n)
    if n < 1 then return 0 : fi
    print n, " =>",
    for i = 1 to n / 2
        if mod(n, i) = 0 then print i, "  "; : fi
    next i
    print n
end sub

printFactors(11)
printFactors(21)
printFactors(32)
printFactors(45)
printFactors(67)
printFactors(96)
print
end


with javascript_semantics
function fperm(sequence fbn, omega)
    integer m=0
    for i=1 to length(fbn) do
        integer g = fbn[i]
        if g>0 then
            omega[m+1..m+g+1] = omega[m+g+1]&omega[m+1..m+g]
        end if
        m += 1
    end for
    return omega
end function

function factorial_base_numbers(integer size, bool countOnly)
-- translation of Go
    sequence results = {}, res = repeat(0,size)
    integer count = 0, n = 0
    while true do
        integer radix = 2, k = n
        while k>0 do
            if not countOnly
            and radix <= size+1 then
                res[size-radix+2] = mod(k,radix)
            end if
            k = floor(k/radix)
            radix += 1
        end while
        if radix > size+2 then exit end if
        count += 1
        if not countOnly then
            results = append(results, deep_copy(res))
        end if
        n += 1
    end while
    return iff(countOnly?count:results)
end function

sequence fbns = factorial_base_numbers(3,false)
for i=1 to length(fbns) do
    printf(1,"%v -> %v\n",{fbns[i],fperm(fbns[i],{0,1,2,3})})
end for
printf(1,"\n")

integer count = factorial_base_numbers(10,true)
printf(1,"Permutations generated = %d\n", count)
printf(1,"  versus factorial(11) = %d\n", factorial(11))

procedure show_cards(sequence s)
    printf(1,"\n")
    for i=1 to length(s) do
        integer c = s[i]-1
        string sep = iff(mod(i,13)=0 or i=length(s)?"\n":" ")
        puts(1,"AKQJT98765432"[mod(c,13)+1]&"SHDC"[floor(c/13)+1]&sep)
    end for
end procedure

function rand_fbn51()
    sequence fbn51 = repeat(0,51)
    for i=1 to 51 do
        fbn51[i] = rand(52-i)
    end for
    return fbn51
end function

sequence fbn51s = {{39,49, 7,47,29,30, 2,12,10, 3,29,37,33,17,12,31,29,
                    34,17,25, 2, 4,25, 4, 1,14,20, 6,21,18, 1, 1, 1, 4,
                     0, 5,15,12, 4, 3,10,10, 9, 1, 6, 5, 5, 3, 0, 0, 0},
                   {51,48,16,22, 3, 0,19,34,29, 1,36,30,12,32,12,29,30,
                    26,14,21, 8,12, 1, 3,10, 4, 7,17, 6,21, 8,12,15,15,
                    13,15, 7, 3,12,11, 9, 5, 5, 6, 6, 3, 4, 0, 3, 2, 1},
                   rand_fbn51()}
for i=1 to length(fbn51s) do
    show_cards(fperm(fbn51s[i],tagset(52)))
end for


-- Extend your language, in Lua, 6/17/2020 db
-- not to be taken seriously, ridiculous, impractical, esoteric, obscure, arcane ... but it works

-------------------
-- IMPLEMENTATION:
-------------------

function if2(cond1, cond2)
  return function(code)
    code = code:gsub("then2", "[3]=load[[")
    code = code:gsub("else1", "]],[2]=load[[")
    code = code:gsub("else2", "]],[1]=load[[")
    code = code:gsub("neither", "]],[0]=load[[")
    code = "return {" .. code .. "]]}"
    local block, err = load(code)
    if (err) then error("syntax error in if2 statement: "..err) end
    local tab = block()
    tab[(cond1 and 2 or 0) + (cond2 and 1 or 0)]()
  end
end

----------
-- TESTS:
----------

for i = 1, 2 do
  for j = 1, 2 do
    print("i="..i.." j="..j)

    if2 ( i==1, j==1 )[[ then2
      print("both conditions are true")
    else1
      print("first is true, second is false")
    else2
      print("first is false, second is true")
    neither
      print("both conditions are false")
    ]]

  end
end


{macro \{if2 (true|false|\{[^{}]*\}) (true|false|\{[^{}]*\})\}
    to {if {and $1 $2}
       then both are true
       else {if {and $1 {not $2}}
       then the first is true
       else {if {and {not $1} $2}
       then the second is true
       else neither are true}}}}

{if2 true true} -> both are true
{if2 true false} -> the first is true
{if2 false true} -> the second is true
{if2 false false} -> neither are true

{if2 {< 1 2} {< 3 4}} -> both are true
{if2 {< 1 2} {> 3 4}} -> the first is true
{if2 {> 1 2} {< 3 4}} -> the second is true
{if2 {> 1 2} {> 3 4}} -> neither are true


fcn f(n){ (1).pump(n.toFloat().sqrt(), List,
   'wrap(m){((n % m)==0) and T(m,n/m) or Void.Skip}) }
fcn g(n){ [[(m); [1..n.toFloat().sqrt()],'{n%m==0}; '{T(m,n/m)} ]] }  // list comprehension


10 INPUT "Enter a number or 0 to exit: ";n
20 IF n=0 THEN STOP
30 PRINT "Factors of ";n;": ";
40 FOR i=1 TO n
50 IF FN m(n,i)=0 THEN PRINT i;" ";
60 NEXT i
70 DEF FN m(a,b)=a-INT (a/b)*b


"""

http://rosettacode.org/wiki/Factorial_base_numbers_indexing_permutations_of_a_collection

https://en.wikipedia.org/wiki/Factorial_number_system

"""

import math

def apply_perm(omega,fbn):
    """

    omega contains a list which will be permuted (scrambled)
    based on fbm.

    fbm is a list which represents a factorial base number.

    This function just translates the pseudo code in the
    Rosetta Code task.

    """
    for m in range(len(fbn)):
        g = fbn[m]
        if g > 0:
            # do rotation
            # save last number
            new_first = omega[m+g]
            # move numbers right
            omega[m+1:m+g+1] = omega[m:m+g]
            # put last number first
            omega[m] = new_first

    return omega

def int_to_fbn(i):
    """

    convert integer i to factorial based number

    """
    current = i
    divisor = 2
    new_fbn = []
    while current > 0:
        remainder = current % divisor
        current = current // divisor
        new_fbn.append(remainder)
        divisor += 1

    return list(reversed(new_fbn))

def leading_zeros(l,n):
   """

   If list l has less than n elements returns l with enough 0 elements
   in front of the list to make it length n.

   """
   if len(l) < n:
       return(([0] * (n - len(l))) + l)
   else:
       return l

def get_fbn(n):
    """

    Return the n! + 1 first Factorial Based Numbers starting with zero.

    """
    max = math.factorial(n)

    for i in range(max):
        # from Wikipedia article
        current = i
        divisor = 1
        new_fbn = int_to_fbn(i)
        yield leading_zeros(new_fbn,n-1)

def print_write(f, line):
    """

    prints to console and
    output file f

    """
    print(line)
    f.write(str(line)+'\n')

def dot_format(l):
    """
    Take a list l that is a factorial based number
    and returns it in dot format.

    i.e. [0, 2, 1] becomes 0.2.1
    """
    # empty list
    if len(l) < 1:
        return ""
    # start with just first element no dot
    dot_string = str(l[0])
    # add rest if any with dots
    for e in l[1:]:
        dot_string += "."+str(e)

    return dot_string

def str_format(l):
    """
    Take a list l and returns a string
    of those elements converted to strings.
    """
    if len(l) < 1:
        return ""

    new_string = ""

    for e in l:
        new_string += str(e)

    return new_string

with open("output.html", "w", encoding="utf-8") as f:
    f.write("<pre>\n")

    # first print list

    omega=[0,1,2,3]

    four_list = get_fbn(4)

    for l in four_list:
        print_write(f,dot_format(l)+' -> '+str_format(apply_perm(omega[:],l)))

    print_write(f," ")

    # now generate this output:
    #
    # Permutations generated = 39916800
    # compared to 11! which  = 39916800

    num_permutations = 0

    for p in get_fbn(11):
        num_permutations += 1
        if num_permutations % 1000000 == 0:
            print_write(f,"permutations so far = "+str(num_permutations))

    print_write(f," ")
    print_write(f,"Permutations generated = "+str(num_permutations))
    print_write(f,"compared to 11! which  = "+str(math.factorial(11)))

    print_write(f," ")

    """

    u"\u2660" - spade

    u"\u2665" - heart

    u"\u2666" - diamond

    u"\u2663" - club

    """

    shoe = []

    for suit in [u"\u2660",u"\u2665",u"\u2666",u"\u2663"]:
        for value in ['A','K','Q','J','10','9','8','7','6','5','4','3','2']:
            shoe.append(value+suit)

    print_write(f,str_format(shoe))

    p1 = [39,49,7,47,29,30,2,12,10,3,29,37,33,17,12,31,29,34,17,25,2,4,25,4,1,14,20,6,21,18,1,1,1,4,0,5,15,12,4,3,10,10,9,1,6,5,5,3,0,0,0]

    p2 = [51,48,16,22,3,0,19,34,29,1,36,30,12,32,12,29,30,26,14,21,8,12,1,3,10,4,7,17,6,21,8,12,15,15,13,15,7,3,12,11,9,5,5,6,6,3,4,0,3,2,1]

    print_write(f," ")
    print_write(f,dot_format(p1))
    print_write(f," ")
    print_write(f,str_format(apply_perm(shoe[:],p1)))

    print_write(f," ")
    print_write(f,dot_format(p2))
    print_write(f," ")
    print_write(f,str_format(apply_perm(shoe[:],p2)))

    # generate random 51 digit factorial based number

    import random

    max = math.factorial(52)

    random_int = random.randint(0, max-1)

    myperm = leading_zeros(int_to_fbn(random_int),51)

    print(len(myperm))

    print_write(f," ")
    print_write(f,dot_format(myperm))
    print_write(f," ")
    print_write(f,str_format(apply_perm(shoe[:],myperm)))

    f.write("</pre>\n")


#!/usr/bin/env python3

HW = r'''
/++++!/===========?\>++.>+.+++++++..+++\
\+++\ | /+>+++++++>/ /++++++++++<<.++>./
$+++/ | \+++++++++>\ \+++++.>.+++.-----\
      \==-<<<<+>+++/ /=.>.+>.--------.-/'''

def snusp(store, code):
    ds = bytearray(store)  # data store
    dp = 0                 # data pointer
    cs = code.splitlines() # 2 dimensional code store
    ipr, ipc = 0, 0        # instruction pointers in row and column
    for r, row in enumerate(cs):
        try:
            ipc = row.index('$')
            ipr = r
            break
        except ValueError:
            pass
    rt, dn, lt, up = range(4)
    id = rt  # instruction direction.  starting direction is always rt
    def step():
        nonlocal ipr, ipc
        if id&1:
            ipr += 1 - (id&2)
        else:
            ipc += 1 - (id&2)
    while ipr >= 0 and ipr < len(cs) and ipc >= 0 and ipc < len(cs[ipr]):
        op = cs[ipr][ipc]
        if op == '>':
            dp += 1
        elif op == '<':
            dp -= 1
        elif op == '+':
            ds[dp] += 1
        elif op == '-':
            ds[dp] -= 1
        elif op == '.':
            print(chr(ds[dp]), end='')
        elif op == ',':
            ds[dp] = input()
        elif op == '/':
            id = ~id
        elif op == '\\':
            id ^= 1
        elif op == '!':
            step()
        elif op == '?':
            if not ds[dp]:
                step()
        step()

if __name__ == '__main__':
    snusp(5, HW)


given .x nxor, .y nxor {
    case true: ...          # both true
    case true, false: ...   # first true, second false
    case false, true: ...   # first false, second true
    default: ...            # both false
}


// Create a type to handle the captures

define if2 => type {
    data private a, private b
    public oncreate(a,b) => {
        .a = #a
        .b = #b
        thread_var_push(.type,self)
        handle => { thread_var_pop(.type)}
        return givenblock()
    }
    public ifboth => .a && .b ? givenblock()
    public else1  => .a && !.b ? givenblock()
    public else2  => !.a && .b ? givenblock()
    public else => !.a && !.b ? givenblock()
}

// Define methods to consider givenblocks

define ifboth => thread_var_get(::if2)->ifboth => givenblock
define else1 => thread_var_get(::if2)->else1 => givenblock
define else2 => thread_var_get(::if2)->else2 => givenblock
define else => thread_var_get(::if2)->else => givenblock


module if2 {
             over 3 : read &c
             c=not (stackitem() and stackitem(2))
}
module ifelse1 {
             over 3 : read &c
             c=not (stackitem() and not stackitem(2))
}
module ifelse2 {
             over 3 : read &c
             c=not (stackitem(2) and not stackitem())
}
module ifelse {
             over 3 : read &c
             c=stackitem() or stackitem(2)
}
module endif2 {
             if not empty then drop 3
}
ctrl=true
for a=1 to 2
      for b=1 to 2
            Print "a=";a, "b=";b
            if2 a=1, b=2, &ctrl : Part {
                  print "both", a, b
            } as ctrl
            ifelse1 : Part {
                  print "first", a
            } as ctrl
            ifelse2  : Part {
                  print "second", b
            } as ctrl
            ifelse  : part {
                  print "no one"
            } as ctrl
            endif2
      next b
next a
Print "ok"


divert(-1)

#
# m4 is a macro language, so this is just a matter of defining a
# macro, using the built-in branching macro "ifelse".
#
# ifelse2(x1,x2,y1,y2,exprxy,exprx,expry,expr)
#
# Checks if x1 and x2 are equal strings and if y1 and y2 are equal
# strings.
#
define(`ifelse2',
  `ifelse(`$1',`$2',`ifelse(`$3',`$4',`$5',`$6')',
          `ifelse(`$3',`$4',`$7',`$8')')')

divert`'dnl
dnl
ifelse2(1,1,2,2,`exprxy',`exprx',`expry',`expr')
ifelse2(1,1,2,-2,`exprxy',`exprx',`expry',`expr')
ifelse2(1,-1,2,2,`exprxy',`exprx',`expry',`expr')
ifelse2(1,-1,2,-2,`exprxy',`exprx',`expry',`expr')


fun main(n: int): int =
  loop((a,b) = (0,1)) = for _i < n do
    (b, a + b)
  in a


  [ 1 swap times [ i 1+ * ] ]   is !            (   n --> n )

  [ dup 0 = iff [ drop 2 ] done
    0
    [ 1+ 2dup ! / 0 = until ]
    nip ]                       is figits       (   n --> n )

  [ [] unrot 1 - times
      [ i 1+ ! /mod
        dip join ] drop ]       is factoradic   ( n n --> [ )

  [ 0 swap
    witheach [ i 1+ ! * + ] ]   is unfactoradic (   [ --> n )

  [ [] unrot witheach
      [ pluck
        rot swap nested join
        swap ]
    join ]                       is inversion   ( [ [ --> [ )

  [ over size
    factoradic inversion ]       is nperm       ( [ n --> [ )

  [ 0 unrot swap witheach
      [ over find
        dup dip [ pluck drop ]
        rot i 1+ * + swap ]
    drop ]                      is permnum      ( [ [ --> n )

  say 'The 1236880662123rd permutation of' cr
  say '"uncopyrightable" is "'
  $ 'uncopyrightable' 1236880662123 nperm echo$
  say '".' cr cr

  say 'The factorial base representation of' cr
  say  '1236880662123 is '
  1236880662123 dup figits factoradic echo
  say '.' cr cr

  say '"lucentbiography" is permutation' cr
  say '#' $ 'lucentbiography' $ 'uncopyrightable' permnum echo
  say ' of "uncopyrightable".'


class SNUSP {

    has @!inst-pointer;
    has @!call-stack;
    has @!direction;
    has @!memory;
    has $!mem-pointer;

    method run ($code) {
        init();
        my @code = pad( |$code.lines );
        for @code.kv -> $r, @l {
           my $index = @l.grep( /'$'/, :k );
           if $index {
               @!inst-pointer = $r, $index;
               last
           }
        }

        loop {
            my $instruction = @code[@!inst-pointer[0]; @!inst-pointer[1]];
            given $instruction {
                when '>'  { $!mem-pointer++ }
                when '<'  { $!mem-pointer-- }
                when '+'  { @!memory[$!mem-pointer]++ }
                when '-'  { @!memory[$!mem-pointer]-- }
                when '.'  { print @!memory[$!mem-pointer].chr }
                when ','  { @!memory[$!mem-pointer] = $*IN.getc.ord }
                when '/'  { @!direction = @!direction.reverse «*» -1 }
                when '\\' { @!direction = @!direction.reverse }
                when '!'  { nexti() }
                when '?'  { nexti() unless @!memory[$!mem-pointer] }
                when '@'  { @!call-stack.push: @!inst-pointer.Array }
                when '#'  {
                    last unless +@!call-stack;
                    @!inst-pointer = |@!call-stack.pop;
                    nexti();
                }
            }
            nexti();
            last if @!inst-pointer[0] > +@code or
                    @!inst-pointer[1] > +@code[0];
        }

        sub init () {
            @!inst-pointer = 0, 0;
            @!direction    = 0, 1;
            $!mem-pointer  = 0;
            @!memory       = ()
        }

        sub nexti () { @!inst-pointer Z+= @!direction }

        sub pad ( *@lines ) {
            my $max = max @lines».chars;
            my @pad = @lines.map: $max - *.chars;
            map -> $i { flat @lines[$i].comb, ' ' xx @pad[$i] }, ^@lines;
        }
    }
}

# TESTING
my $hw = q:to/END/;
    /++++!/===========?\>++.>+.+++++++..+++\
    \+++\ | /+>+++++++>/ /++++++++++<<.++>./
    $+++/ | \+++++++++>\ \+++++.>.+++.-----\
          \==-<<<<+>+++/ /=.>.+>.--------.-/
    END

my $snusp = SNUSP.new;
$snusp.run($hw)


If2[test1_, test2_, condBoth_, cond1_, cond2_, condNone_] := With[
   {result1 = test1,
    result2 = test2},
   Which[
    result1 && result2, condBoth,
    result1, cond1,
    result2, cond2,
    True, condNone]];
SetAttributes[If2, HoldAll];


(
  :none :two :one :both -> :r2 -> :r1
  (
    ((r1 r2 and)(both))
    ((r1)(one))
    ((r2)(two))
    ((true)(none))
  ) case
) :if2

(3 4 >) (0 0 ==)
("both are true")
("the first is true")
("the second is true")
("both are false")
if2 puts!   ;the second is true

;compare to regular if
(4 even?)
("true")
("false")
if puts!   ;true


import morfa.base;

// introduce 4 new operators to handle the if2 syntax
operator then   { kind = infix,   precedence = mul,   associativity = right}
operator else1  { kind = infix,   precedence = not,   associativity = left }
operator else2  { kind = infix,   precedence = not,   associativity = left }
operator none   { kind = infix,   precedence = not,   associativity = left }

// function which bounds the condition expression to the if2 "actions"
public func then(condition: IF2.Condition, actionHolder: IF2): void
{
    actionHolder.actions[condition]();
}

// functions (bound to operators) used to "build" the if2 "statement"
public func else1(bothAction: func(): void, else1Action: func(): void): IF2
{
    return IF2([IF2.Condition.both -> bothAction,
                IF2.Condition.else1 -> else1Action]);

}
public func else2(actionHolder: IF2, action: func(): void): IF2
{
    return checkAndAdd(actionHolder, action, IF2.Condition.else2);
}
public func none(actionHolder: IF2, action: func(): void): IF2
{
    return checkAndAdd(actionHolder, action, IF2.Condition.none);
}

// finally, function which combines two conditions into a "trigger" for the if2 "statement"
public func if2(condition1: bool, condition2: bool): IF2.Condition
{
    if (condition1 and condition2)
        return IF2.Condition.both;
    else if (condition1)
        return IF2.Condition.else1;
    else if (condition2)
        return IF2.Condition.else2;
    else
        return IF2.Condition.none;
}

// private helper function to build the IF2 structure
func checkAndAdd(actionHolder: IF2, action: func(): void, actionName: IF2.Condition): IF2
{
    if (actionHolder.actions.contains(actionName))
        throw new Exception("action defined twice for one condition in if2");
    else
        actionHolder.actions[actionName] = action;
    return actionHolder;
}

// helper structure to process the if2 "statement"
struct IF2
{
    public enum Condition { both, else1, else2, none };
    public var actions: Dict<Condition, func(): void>;
}

// usage
if2 (true, false) then func()
{
    println("both true");
}
else1 func()
{
    println("first true");
}
else2 func()
{
    println("second true");
}
none func()
{
    println("none true");
};


// point of interest: the when keyword and && operator inside the macro definition are macros themselves

macro if2 (cond1, cond2, bodyTT, bodyTF, bodyFT, bodyFF)
syntax ("if2", "(", cond1, ")", "(", cond2, ")", bodyTT, "elseTF", bodyTF, "elseFT", bodyFT, "else", bodyFF)
{
    <[
        when($cond1 && $cond2) {$bodyTT};
        when($cond1 && !($cond2)) {$bodyTF};
        when(!($cond1) && $cond2) {$bodyFT};
        when(!($cond1) && !($cond2)) {$bodyFF};
    ]>
}


window 1, @"Fibonacci Sequence", (0,0,480,620)

local fn Fibonacci( n as long ) as long
  static long s1
  static long s2
  long        temp

  if ( n < 2 )
    s1 = n
    exit fn
  else
    temp = s1 + s2
    s2 = s1
    s1 = temp
    exit fn
  end if
end fn = s1

long i
CFTimeInterval t

t = fn CACurrentMediaTime

for i = 0 to 40
  print i;@".\t";fn Fibonacci(i)
next i

print : printf @"Compute time: %.3f ms",(fn CACurrentMediaTime-t)*1000

HandleEvents


import "random" for Random
import "/math" for Int
import "/fmt" for Fmt

var genFactBaseNums = Fn.new { |size, countOnly|
    var results = []
    var count = 0
    var n = 0
    while (true) {
        var radix = 2
        var res = null
        if (!countOnly) res = List.filled(size, 0)
        var k = n
        while (k > 0) {
            var div = (k/radix).floor
            var rem = k % radix
            if (!countOnly) {
                if (radix <= size + 1) res[size-radix+1] = rem
            }
            k = div
            radix = radix + 1
         }
         if (radix > size+2) break
         count = count + 1
         if (!countOnly) results.add(res)
         n = n + 1
    }
    return [results, count]
}

var mapToPerms = Fn.new { |factNums|
    var perms = []
    var psize = factNums[0].count + 1
    var start = List.filled(psize, 0)
    for (i in 0...psize) start[i] = i
    for (fn in factNums) {
        var perm = start.toList
        for (m in 0...fn.count) {
            var g = fn[m]
            if (g != 0) {
                var first = m
                var last = m + g
                for (i in 1..g) {
                    var temp = perm[first]
                    for (j in first+1..last) perm[j-1] = perm[j]
                    perm[last] = temp
                }
            }
        }
        perms.add(perm)
    }
    return perms
}

var join = Fn.new { |ints, sep| ints.map { |i| i.toString }.join(sep) }

var undot = Fn.new { |s| s.split(".").map { |ss| Num.fromString(ss) }.toList }

var rand = Random.new()

// Recreate the table.
var factNums = genFactBaseNums.call(3, false)[0]
var perms = mapToPerms.call(factNums)
var i = 0
for (fn in factNums) {
    Fmt.print("$s -> $s", join.call(fn, "."), join.call(perms[i], ""))
    i = i + 1
}

// Check that the number of perms generated is equal to 11! (this takes a while).
var count = genFactBaseNums.call(10, true)[1]
Fmt.print("\nPermutations generated = $,d", count)
Fmt.print("compared to 11! which  = $,d", Int.factorial(11))
System.print()

// Generate shuffles for the 2 given 51 digit factorial base numbers.
var fbn51s = [
    "39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0",
    "51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"
]
factNums = [undot.call(fbn51s[0]), undot.call(fbn51s[1])]
perms = mapToPerms.call(factNums)
var shoe = "A♠K♠Q♠J♠T♠9♠8♠7♠6♠5♠4♠3♠2♠A♥K♥Q♥J♥T♥9♥8♥7♥6♥5♥4♥3♥2♥A♦K♦Q♦J♦T♦9♦8♦7♦6♦5♦4♦3♦2♦A♣K♣Q♣J♣T♣9♣8♣7♣6♣5♣4♣3♣2♣".toList
var cards = List.filled(52, null)
for (i in 0..51) {
    cards[i] = shoe[2*i..2*i+1].join()
    if (cards[i][0] == "T") cards[i] = "10" + cards[i][1..-1]
}
i = 0
for (fbn51 in fbn51s) {
    System.print(fbn51)
    for (d in perms[i]) System.write(cards[d])
    System.print("\n")
    i = i + 1
}

// Create a random 51 digit factorial base number and produce a shuffle from that.
var fbn51 = List.filled(51, 0)
for (i in 0..50) fbn51[i] = rand.int(52-i)
System.print(join.call(fbn51, "."))
perms = mapToPerms.call([fbn51])
for (d in perms[0]) System.write(cards[d])
System.print()


(context 'if2)

(define-macro (if2:if2 cond1 cond2 both-true first-true second-true neither)
  (cond
    ((eval cond1)
      (if (eval cond2)
            (eval both-true)
            (eval first-true)))
    ((eval cond2)
      (eval second-true))
    (true
      (eval neither))))

(context MAIN)

> (if2 true true 'bothTrue 'firstTrue 'secondTrue 'else)
bothTrue
> (if2 true false 'bothTrue 'firstTrue 'secondTrue 'else)
firstTrue
> (if2 false true 'bothTrue 'firstTrue 'secondTrue 'else)
secondTrue
> (if2 false false 'bothTrue 'firstTrue 'secondTrue 'else)
else


import macros

proc newIfElse(c, t, e: NimNode): NimNode {.compiletime.} =
  result = newIfStmt((c, t))
  result.add(newNimNode(nnkElse).add(e))

macro if2(x, y: bool; z: untyped): untyped =
  var parts: array[4, NimNode]
  for i in parts.low .. parts.high:
    parts[i] = newNimNode(nnkDiscardStmt).add(NimNode(nil))

  assert z.kind == nnkStmtList
  assert z.len <= 4

  for i in 0 ..< z.len:
    assert z[i].kind == nnkCall
    assert z[i].len == 2

    var j = 0

    case $z[i][0]
    of "then":  j = 0
    of "else1": j = 1
    of "else2": j = 2
    of "else3": j = 3
    else: assert false

    parts[j] = z[i][1].last

  result = newIfElse(x,
    newIfElse(y, parts[0], parts[1]),
    newIfElse(y, parts[2], parts[3]))

if2 2 > 1, 3 < 2:
  then:
    echo "1"
  else1:
    echo "2"
  else2:
    echo "3"
  else3:
    echo "4"

# Missing cases are supported:
if2 2 > 1, 3 < 2:
  then:
    echo "1"
  else2:
    echo "3"
  else3:
    echo "4"

# Order can be swapped:
if2 2 > 1, 3 < 2:
  then:
    echo "1"
  else2:
    echo "3"
  else1:
    echo "2"
  else3:
    echo "4"


fib := function(n)
  local a;
  a := [[0, 1], [1, 1]]^n;
  return a[1][2];
end;


fcn fpermute(omega,num){  // eg (0,1,2,3), (0,0,0)..(3,2,1)
   omega=omega.copy(); 	  // omega gonna be mutated
   foreach m,g in ([0..].zip(num)){ if(g) omega.insert(m,omega.pop(m+g)) }
   omega
}


$ include "seed7_05.s7i";

const proc: snusp (in string: sourceCode, in integer: memSize, inout file: input, inout file: output) is func
  local
    var array string: instructions is 0 times "";
    var array char: memory is 0 times ' ';
    var integer: dataPointer is 1;
    var integer: instrPtrRow is 0;
    var integer: instrPtrColumn is 0;
    var integer: rowDir is 0;
    var integer: columnDir is 1;
    var integer: helpDir is 0;
    var integer: row is 0;
  begin
    instructions := split(sourceCode, "\n");
    memory := memSize times '\0;';

    for key row range instructions do
      if pos(instructions[row], '$') <> 0 then
        instrPtrRow := row;
        instrPtrColumn := pos(instructions[row], '$');
      end if;
    end for;

    while instrPtrRow >= 1 and instrPtrRow <= length(instructions) and
        instrPtrColumn >= 1 and instrPtrColumn <= length(instructions[instrPtrRow]) do
      case instructions[instrPtrRow][instrPtrColumn] of
        when {'>'}:  incr(dataPointer);
        when {'<'}:  decr(dataPointer);
        when {'+'}:  incr(memory[dataPointer]);
        when {'-'}:  decr(memory[dataPointer]);
        when {'.'}:  write(output, memory[dataPointer]);
        when {','}:  memory[dataPointer] := getc(input);
        when {'/'}:  helpDir := rowDir;
                     rowDir := -columnDir;
                     columnDir := -helpDir;
        when {'\\'}: helpDir := rowDir;
                     rowDir := columnDir;
                     columnDir := helpDir;
        when {'!'}:  instrPtrRow +:= rowDir;
                     instrPtrColumn +:= columnDir;
        when {'?'}:  if memory[dataPointer] = '\0;' then
                       instrPtrRow +:= rowDir;
                       instrPtrColumn +:= columnDir;
                     end if;
      end case;
      instrPtrRow +:= rowDir;
      instrPtrColumn +:= columnDir;
    end while;
  end func;

# SNUSP implementation of Hello World.
const string: helloWorld is "/++++!/===========?\\>++.>+.+++++++..+++\\\n\
                            \\\+++\\ | /+>+++++++>/ /++++++++++<<.++>./\n\
                            \$+++/ | \\+++++++++>\\ \\+++++.>.+++.-----\\\n\
                            \      \\==-<<<<+>+++/ /=.>.+>.--------.-/";

const proc: main is func
  begin
    snusp(helloWorld, 5, IN, OUT);
  end func;


import "io" for Stdin

// 'raw' is a multi-line string
var snusp = Fn.new { |dlen, raw|
    var ds = List.filled(dlen, 0) // data store
    var dp = 0 // data pointer

    // remove leading \n if it's there
    if (raw[0] == "\n") raw = raw[1..-1]

    // make 2 dimensional instruction store & declare instruction pointers
    var s = raw.split("\n")
    var ipr = 0
    var ipc = 0

    // look for starting instruction
    for (r in 0...s.count) {
        var row = s[r]
        var outer = false
        for (c in 0...row.count) {
            var i = row[c]
            if (i == "$") {
                ipr = r
                ipc = c
                outer = true
                break
            }
        }
        if (outer) break
    }

    var id = 0
    var step = Fn.new {
        if (id&1 == 0) {
            ipc = ipc + 1 - (id&2)
        } else {
            ipr = ipr + 1 - (id&2)
        }
    }

    // execute
    while (ipr >= 0 && ipr < s.count && ipc >= 0 && ipc < s[ipr].count) {
        var c = s[ipr][ipc]
        if (c == ">") {
            dp = dp + 1
        } else if (c == "<") {
            dp = dp - 1
        } else if (c == "+") {
            ds[dp] = ds[dp] + 1
        } else if (c == "-") {
            ds[dp] = ds[dp] - 1
        } else if (c == ".") {
            System.write(String.fromByte(ds[dp]))
        } else if (c == ",") {
            ds[dp] = Stdin.readByte()
        } else if (c == "/") {
            id = ~id
        } else if (c == "\\") {
            id = id ^ 1
        } else if (c == "!") {
            step.call()
        } else if (c == "?") {
            if (ds[dp] == 0) step.call()
        }
        step.call()
    }
}

var hw =
    "/++++!/===========?\\>++.>+.+++++++..+++\\\n" +
    "\\+++\\ | /+>+++++++>/ /++++++++++<<.++>./\n" +
    "$+++/ | \\+++++++++>\\ \\+++++.>.+++.-----\\\n" +
    "      \\==-<<<<+>+++/ /=.>.+>.--------.-/"
snusp.call(5, hw)


(* Languages with pattern matching ALREADY HAVE THIS! *)

let myfunc pred1 pred2 =
  match (pred1, pred2) with
  | (true, true) -> print_endline ("(true, true)");
  | (true, false) -> print_endline ("(true, false)");
  | (false, true) -> print_endline ("(false, true)");
  | (false, false) -> print_endline ("(false, false)");;

myfunc true true;;
myfunc true false;;
myfunc false true;;
myfunc false false;;


if2(c1,c2,tt,tf,ft,ff)={
  if(c1,
    if(c2,tt,tf)
  ,
    if(c2,ft,ff)
  )
};


#!/usr/bin/perl
use warnings;
use strict;
use v5.10;

=for starters

Syntax:

    if2 condition1, condition2, then2 {
        # both conditions are true
    }
    else1 {
        # only condition1 is true
    }
    else2 {
        # only condition2 is true
    }
    orelse {
        # neither condition is true
    };

Any (but not all) of the `then' and `else' clauses can be omitted, and else1
and else2 can be specified in either order.

This extension is imperfect in several ways:
* A normal if-statement uses round brackets, but this syntax forbids them.
* Perl doesn't have a `then' keyword; if it did, it probably wouldn't be
  preceded by a comma.
* Unless it's the last thing in a block, the whole structure must be followed
  by a semicolon.
* Error messages appear at runtime, not compile time, and they don't show the
  line where the user's syntax error occurred.

We could solve most of these problems with a source filter, but those are
dangerous.  Can anyone else do better?  Feel free to improve or replace.

=cut

# All the new `keywords' are in fact functions.  Most of them return lists
# of four closures, one of which is then executed by if2.  Here are indexes into
# these lists:

use constant {
    IdxThen     => 0,
    IdxElse1    => 1,
    IdxElse2    => 2,
    IdxOrElse   => 3
};

# Most of the magic is in the (&) prototype, which lets a function accept a
# closure marked by nothing except braces.

sub orelse(&) {
    my $clause = shift;
    return undef, undef, undef, $clause;
}

sub else2(&@) {
    my $clause = shift;
    die "Can't have two `else2' clauses"
        if defined $_[IdxElse2];

    return (undef, $_[IdxElse1], $clause, $_[IdxOrElse]);
}

sub else1(&@) {
    my $clause = shift;
    die "Can't have two `else1' clauses"
        if defined $_[IdxElse1];

    return (undef, $clause, $_[IdxElse2], $_[IdxOrElse]);
}

sub then2(&@) {
    die "Can't have two `then2' clauses"
        if defined $_[1+IdxThen];

    splice @_, 1+IdxThen, 1;
    return @_;
}

# Here, we collect the two conditions and four closures (some of which will be
# undefined if some clauses are missing).  We work out which of the four
# clauses (closures) to call, and call it if it exists.

use constant {
    # Defining True and False is almost always bad practice, but here we
    # have a valid reason.
    True  => (0 == 0),
    False => (0 == 1)
};

sub if2($$@) {
    my $cond1 = !!shift;    # Convert to Boolean to guarantee matching
    my $cond2 = !!shift;    # against either True or False

    die "if2 must be followed by then2, else1, else2, &/or orelse"
        if @_ != 4
        or grep {defined and ref $_ ne 'CODE'} @_;

    my $index;
    if (!$cond1 && !$cond2) {$index = IdxOrElse}
    if (!$cond1 &&  $cond2) {$index = IdxElse2 }
    if ( $cond1 && !$cond2) {$index = IdxElse1 }
    if ( $cond1 &&  $cond2) {$index = IdxThen  }

    my $closure = $_[$index];
    &$closure   if defined $closure;
}

# This is test code.  You can play with it by deleting up to three of the
# four clauses.

sub test_bits($) {
    (my $n) = @_;

    print "Testing $n: ";

    if2 $n & 1, $n & 2, then2 {
        say "Both bits 0 and 1 are set";
    }
    else1 {
        say "Only bit 0 is set";
    }
    else2 {
        say "Only bit 1 is set";
    }
    orelse {
        say "Neither bit is set";
    }
}

test_bits $_   for 0 .. 7;