Skip to content

@tjweir /puzzle.ml forked from philtomson/puzzle.ml
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Solve a puzzle posed on NPR (see: http://www.npr.org/2012/01/29/146034893/this-puzzle-is-the-pits - "Next Week" section )
(* Inspired by this puzzle from NPR:
http://www.npr.org/2012/01/29/146034893/this-puzzle-is-the-pits
(see the 'Next Weeks' challenge section there):
"Next Week's Challenge from listener Ed Pegg Jr.: Write the digits from
1 to 9 in a line. If you put times signs after the 2 and 4, a plus
sign after the 5, and a minus sign after the 7, you have
12 x 34 x 5 + 67 - 89, which equals 2018.
That's six years off from our current year 2012. This example uses
four arithmetic symbols. The object is to use just three of the
following arithmetic operations: addition, subtraction, multiplication
and division, in a line from 1 to 9 to get 2012 exactly. The operations
should be performed in order from left to right" *)
(*NOTE: the difference in my implementation is that instead of the
* operations being performed left to right, I follow mathematical
* precedence: perform * and / first, then perform + and -
*)
(* This program solves the puzzle above using a genetic algorithm *)
Random.init 42 ;;
let nums = [1; 2; 3; 4; 5; 6; 7; 8; 9];;
let ops = [ "C"; "C"; "+"; "C"; "*"; "C"; "/"; "+"] ;;
let num_size = List.length nums;;
let ops_size = num_size - 1 ;;
let target = 2012;;
let mutation_rate = 0.10 ;;
exception SizeMismatch;;
type ops = Num of int
| Add of int * int
| Sub of int * int
| Mult of int * int
| Div of int * int
;;
let num_to_op rn = match rn with
0 -> "C"
| 1 -> "+"
| 2 -> "-"
| 3 -> "*"
| 4 -> "/"
| _ -> "C" ;;
(* C + - * / *)
let build_rnd_ops len =
let rec aux outlst len' = match len' with
0 -> outlst
| _ ->
let rndnum = Random.int 5 in
let op = num_to_op rndnum in
aux (op::outlst) (len'-1) in
aux [] len ;;
let rotate_left lst = (List.tl lst) @ [(List.hd lst)] ;;
let rotate_right lst = List.rev (rotate_left (List.rev lst));;
let mutate ops =
let ops_len = List.length ops in
let copy_all_but oplst n newop =
let rec aux inlst outlst i = match inlst with
[] -> List.rev outlst
| x::xs -> let op = if i = n then
newop
else
x in
(aux xs (op::outlst) (i+1)) in
aux ops [] 0 in
if (Random.float 1.0 ) < mutation_rate then
copy_all_but ops (Random.int ops_len ) (num_to_op (Random.int 5))
else
ops ;;
let combine n_lst op_lst =
let op_lst_len = List.length op_lst in
let rec build' n_lst' outlst i = match n_lst' with
[] -> List.rev outlst
| n::ns -> if i < op_lst_len then
build' ns ( (List.nth op_lst i)::n::outlst) (i+1)
else
build' ns ( n::outlst) (i+1) in
build' n_lst [] 0 ;;
let cross a b =
let rec aux a' b' aout bout = match (a',b') with
([],[]) -> [List.rev aout; List.rev bout]
| (an1::an2::a3::[], bn1::bn2::b3::[]) ->
aux [] [] (a3::bn2::an1::aout) (b3::an2::bn1::bout)
| (an1::an2::ans, bn1::bn2::bns) ->
aux ans bns (bn2::an1::aout) (an2::bn1::bout)
| (_::[],[]) | ([], _::[]) | (_,_) -> raise SizeMismatch in
aux a b [] [] ;;
let rec scramble lst = match lst with
| [] -> []
| [a] -> [a]
| x::y::t -> y::x::scramble t ;;
let swap_ops lst =
let len = List.length lst in
let r1 = Random.int len in
let r2 = Random.int len in
let e1 = List.nth lst r1 in
let e2 = List.nth lst r2 in
let rec mapi i accum l = match l with
| [] -> List.rev accum
| x::xs -> let item = (match i with
a when a = r1 -> e2
| b when b = r2 -> e1
| _ -> x
) in
mapi (i+1) (item::accum) xs in
mapi 0 [] lst ;;
let cat n_oplst =
let rec do_cat nolst outs accum = match nolst with
[] -> List.rev outs
| n::op::nos -> if op = "C" then
do_cat nos outs (accum ^ n)
else
do_cat nos (op::(accum^n)::outs) ""
| n::[] -> do_cat [] ((accum^n)::outs) (accum^n)
in
do_cat n_oplst [] "";;
let do_mult_div lst =
let rec md nlst outs accum oper = match nlst with
[] -> List.rev outs
| n::op::ns -> let n' = int_of_string n in
(match op with
"*" -> md ns outs (oper accum n' ) ( * )
| "/" -> md ns outs (oper accum n' ) ( / )
| _ -> md ns
(op:: (string_of_int (oper accum n')) ::outs)
1 oper
)
| n::[] -> let n' = int_of_string n in
md [] ( (string_of_int(oper accum n'))::outs ) (oper accum n') oper in
md lst [] 1 ( * ) ;;
let do_add_sub lst =
let rec addsub nlst outs accum oper = match nlst with
[] -> List.rev outs
| n::op::ns -> let n' = int_of_string n in
(match op with
"+" -> addsub ns outs (oper accum n') ( + )
| "-" -> addsub ns outs (oper accum n') ( - )
| _ -> addsub ns (op:: (string_of_int (oper accum n'))::outs) 0 oper )
| n::[] -> let n' = int_of_string n in
addsub [] ((string_of_int(oper accum n'))::outs) (oper accum n') oper in
addsub lst [] 0 ( + ) ;;
let create_pop size =
let rec aux pop s = match s with
0 -> pop
| _ -> aux ((build_rnd_ops ops_size)::pop) (s-1) in
aux [] size ;;
let ( |> ) a b = b a ;;
exception EvalError;;
let n_op_lst = combine ( List.map (fun x -> string_of_int x) nums) ops ;;
let eval lst =
let lst' = (combine (List.map (fun x -> string_of_int x) nums) lst) in
let res_lst = (cat lst' |> do_mult_div |> do_add_sub) in
if (List.length res_lst > 1) || (List.length res_lst = 0) then
raise EvalError
else int_of_string( List.nth res_lst 0) ;;
let delta t n = abs (t - n) ;;
let rank_pop pop = List.sort (fun a b ->
if abs (target - (fst a)) > abs (target - (fst b)) then
1
else if a = b then
0
else -1
) (List.map (fun e ->
(* TODO: 'try' in case of / 0 *)
(eval e) , e ) pop) ;;
let runit gens =
let population = create_pop 24 in
let rec aux pop gen bestest = match gen with
0 -> (eval bestest),bestest,(rank_pop pop)
| _ -> let ranked_pop = rank_pop pop in
let best1 = snd (List.nth ranked_pop 0) in
let best2 = snd (List.nth ranked_pop 1) in
let pop' = List.map (fun i -> mutate i )
(cross best1 best2) @
(cross (List.rev best2) best1) @
(cross best2 (List.rev best1)) @
(create_pop 17) in
let pop'' = pop' @ [ bestest] in (*don't mutate bestest *)
aux pop'' (gen-1)
(if (delta target (eval best1)) <
(delta target (eval bestest)) then
(
(Printf.printf "gen: %d: best1 better than bestest: %d : %d\n"
(gens-gen) (eval best1) (eval bestest) );
best1
)
else
bestest
)in
aux population gens (List.nth population 0)
;;
let value, best, ranked_pop = runit 5000 ;;
List.map (fun x ->
Printf.printf "%s : %d\n"
(String.concat ""
(combine (List.map (fun s -> string_of_int s) nums) (snd x)
))
(fst x) ) ranked_pop ;;
let best = List.nth ranked_pop 0 in
Printf.printf "Best answer is: %s = %d\n"
(String.concat ""
(List.filter (fun cr -> cr <> "C" )
(combine (List.map
(fun s -> string_of_int s) nums)
(snd best)
)
)
)
(fst best);;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.