langs a-z

Task/24-game-Solve/OCaml/24-game-solve.ocaml

@@ -0,0 +1,70 @@
+type expression =
+  | Const of float
+  | Sum  of expression * expression   (* e1 + e2 *)
+  | Diff of expression * expression   (* e1 - e2 *)
+  | Prod of expression * expression   (* e1 * e2 *)
+  | Quot of expression * expression   (* e1 / e2 *)
+
+let rec eval = function
+  | Const c -> c
+  | Sum (f, g) -> eval f +. eval g
+  | Diff(f, g) -> eval f -. eval g
+  | Prod(f, g) -> eval f *. eval g
+  | Quot(f, g) -> eval f /. eval g
+
+let print_expr expr =
+  let open_paren prec op_prec =
+    if prec > op_prec then print_string "(" in
+  let close_paren prec op_prec =
+    if prec > op_prec then print_string ")" in
+  let rec print prec = function   (* prec is the current precedence *)
+    | Const c -> Printf.printf "%g" c
+    | Sum(f, g) ->
+        open_paren prec 0;
+        print 0 f; print_string " + "; print 0 g;
+        close_paren prec 0
+    | Diff(f, g) ->
+        open_paren prec 0;
+        print 0 f; print_string " - "; print 1 g;
+        close_paren prec 0
+    | Prod(f, g) ->
+        open_paren prec 2;
+        print 2 f; print_string " * "; print 2 g;
+        close_paren prec 2
+    | Quot(f, g) ->
+        open_paren prec 2;
+        print 2 f; print_string " / "; print 3 g;
+        close_paren prec 2
+  in
+  print 0 expr
+
+let rec insert v = function
+  | [] -> [[v]]
+  | x::xs as li -> (v::li) :: (List.map (fun y -> x::y) (insert v xs))
+
+let permutations li =
+  List.fold_right (fun x z -> List.concat (List.map (insert x) z)) li [[]]
+
+let rec comp expr = function
+  | x::xs ->
+      comp (Sum (expr, x)) xs;
+      comp (Diff(expr, x)) xs;
+      comp (Prod(expr, x)) xs;
+      comp (Quot(expr, x)) xs;
+  | [] ->
+      if (eval expr) = 24.0
+      then (print_expr expr; print_newline())
+;;
+
+let () =
+  Random.self_init();
+  let digits = Array.init 4 (fun _ -> 1 + Random.int 9) in
+  print_string "Input digits: ";
+  Array.iter (Printf.printf " %d") digits; print_newline();
+  let digits = Array.to_list(Array.map float_of_int digits) in
+  let digits = List.map (fun v -> Const v) digits in
+  let all = permutations digits in
+  List.iter (function
+    | x::xs -> comp x xs
+    | [] -> assert false
+  ) all

Task/24-game-Solve/Perl-6/24-game-solve.pl6

@@ -0,0 +1,61 @@
+my @digits;
+my $amount = 4;
+
+# Get $amount digits from the user,
+# ask for more if they don't supply enough
+while @digits.elems < $amount {
+    @digits ,= (prompt "Enter {$amount - @digits} digits from 1 to 9, "
+    ~ '(repeats allowed): ').comb(/<[1..9]>/);
+}
+# Throw away any extras
+@digits = @digits[^$amount];
+
+# Generate combinations of operators
+my @op = <+ - * />;
+my @ops = map {my $a = $_; map {my $b = $_; map {[$a,$b,$_]}, @op}, @op}, @op;
+
+# Enough sprintf formats to cover most precedence orderings
+my @formats = (
+    '%d %s %d %s %d %s %d',
+    '(%d %s %d) %s %d %s %d',
+    '(%d %s %d %s %d) %s %d',
+    '((%d %s %d) %s %d) %s %d',
+    '(%d %s %d) %s (%d %s %d)',
+    '%d %s (%d %s %d %s %d)',
+    '%d %s (%d %s (%d %s %d))',
+);
+
+# Brute force test the different permutations
+for unique permutations @digits -> @p {
+    for @ops -> @o {
+        for @formats -> $format {
+            my $string = sprintf $format, @p[0], @o[0],
+                     @p[1], @o[1], @p[2], @o[2], @p[3];
+            my $result = try { eval($string) };
+            say "$string = 24" and last if $result and $result == 24;
+        }
+    }
+}
+
+# Perl 6 translation of Fischer-Krause ordered permutation algorithm
+sub permutations (@array) {
+    my @index = ^@array;
+    my $last = @index[*-1];
+    my (@permutations, $rev, $fwd);
+    loop {
+        push @permutations, [@array[@index]];
+        $rev = $last;
+        --$rev while $rev and @index[$rev-1] > @index[$rev];
+        return @permutations unless $rev;
+        $fwd = $rev;
+        push @index, @index.splice($rev).reverse;
+	++$fwd while @index[$rev-1] > @index[$fwd];
+	@index[$rev-1,$fwd] = @index[$fwd,$rev-1];
+    }
+}
+
+# Only return unique sub-arrays
+sub unique (@array) {
+    my %h = map { $_.Str => $_ }, @array;
+    %h.values;
+}

Task/24-game-Solve/ProDOS/24-game-solve-1.dos

@@ -0,0 +1,35 @@
+editvar /modify -random- = <10
+:a
+editvar /newvar /withothervar /value=-random- /title=1
+editvar /newvar /withothervar /value=-random- /title=2
+editvar /newvar /withothervar /value=-random- /title=3
+editvar /newvar /withothervar /value=-random- /title=4
+printline These are your four digits: -1- -2- -3- -4-
+printline Use an algorithm to make the number 24.
+editvar /newvar /value=a /userinput=1 /title=Algorithm:
+do -a-
+if -a- /hasvalue 24 printline Your algorithm worked! & goto :b (
+) else printline Your algorithm did not work.
+editvar /newvar /value=b /userinput=1 /title=Do you want to see how you could have done it?
+if -b- /hasvalue y goto :c else goto :b
+:b
+editvar /newvar /value=c /userinput=1 /title=Do you want to play again?
+if -c- /hasvalue y goto :a else exitcurrentprogram
+:c
+editvar /newvar /value=do -1- + -2- + -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- - -2- + -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- / -2- + -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- * -2- + -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- - -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- / -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- * -3- + -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- + -3- - -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- + -3- / -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- + -2- + -3- * -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- - -2- - -3- - -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- / -2- / -3- / -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+editvar /newvar /value=do -1- * -2- * -3- * -4- /title=c & do -c- >d & if -d- /hasvalue 24 goto :solve
+:solve
+printline you could have done it by doing -c-
+stoptask
+goto :b

Task/24-game-Solve/ProDOS/24-game-solve-2.dos

@@ -0,0 +1,11 @@
+These are your four digits: 1 4 5 2
+Use an algorithm to make the number 24.
+Algorithm: 4 + 2 - 5 + 1
+Your algorithm did not work.
+Do you want to play again? y
+
+These are your four digits: 1 8 9 6
+Use an algorithm to make the number 24.
+Algorithm: 1 + 8 + 9 + 6
+Your algorithm worked!
+Do you want to play again? n

Task/24-game-Solve/Ursala/24-game-solve-1.ursala

@@ -0,0 +1,11 @@
+#import std
+#import nat
+#import rat
+
+tree_shapes = "n". (@vLPiYo //eql iota "n")*~ (rep"n" ~&iiiK0NlrNCCVSPTs) {0^:<>}
+with_leaves = ^|DrlDrlK34SPSL/permutations ~&
+with_roots  = ^DrlDrlK35dlPvVoPSPSL\~&r @lrhvdNCBvLPTo2DlS @hiNCSPtCx ~&K0=>
+value       = *^ ~&v?\(@d ~&\1) ^|H\~&hthPX '+-*/'-$<sum,difference,product,quotient>
+format      = *^ ~&v?\-+~&h,%zP@d+- ^H/mat@d *v ~&t?\~& :/`(+ --')'
+
+game"n" "d" = format* value==("n",1)*~ with_roots/'+-*/' with_leaves/"d"*-1 tree_shapes length "d"

Task/24-game-Solve/Ursala/24-game-solve-2.ursala

@@ -0,0 +1,3 @@
+#show+
+
+test_games = mat` * pad` *K7 pad0 game24* <<2,3,8,9>,<5,7,4,1>,<5,6,7,8>>