klotski.ml

(*
#1
loop : ('a -> bool) -> ('a -> 'a) -> 'a -> 'a 
such that loop p f x = x when p x = true and loop p f x = loop p f (f x) otherwise. 
*)
let rec loop p f x = if p x then x else loop p f (f x);;

(*
#2
exists : ('a -> bool) -> 'a list -> bool 
such that exists p l = true if and only if there exists an element x of l such that p x = true. 
*)
let rec exists p l =
  match l with
  | [] -> false
  | x::xs -> if p x then true else exists p xs
;;

(*
#3
find : ('a -> bool) -> 'a list -> 'a 
such that find p l = x if x is the first element of l for which p x = true. 
If no such element exists, find raises the exception NotFound given in the prelude. 
*)
let rec find p l =
  match l with
  | [] -> NotFound
  | x::xs -> if p x then x else find p xs
;;

(* --- Part A: A Generic Problem Solver --- *)

(*
#4
near : int 
`rel` that encodes the image of this relation as an OCaml function. 
For instance, `near 2` should return something like [0;1;2;3;4]. 
*)
let near x = [x-2; x-1; x; x+1; x+2];;


(*
#5
flat_map : 'e rel -> ('e list -> 'e list) 
such that flat_map r represents R¯¯ if r represents a binary relation R.
For instance, flat_map near applied to [2;3;4] should return something like [0;1;2;3;4;1;2;3;4;5;2;3;4;5;6]. 
*)
let rec flat_map (r:'e rel) = 
  let rec flat ls = 
    match ls with
    | [] -> []
    | x::xs -> (r x) @ (flat xs)
  in
  flat
;;

(*
#6
iter_rel : 'e rel -> int -> 'e rel 
Iterating a relation 1 time or less does nothing (identity).
For instance, iter_rel near 2 should be the image function of the relation that tells 
its two integers are separated by 4 of less. 
*)
let rec iter_rel rel n =
  if n <= 1 then rel
  else 
    fun e ->
      flat_map (iter_rel rel (n - 1)) (rel e) 
;;

(*
#7   
solve : 'a rel -> 'a prop -> 'a -> 'a
computes the iteration of the relation R represented by r starting at x until
it reaches an element y such that p y. 
*)
let solve r p x =
  let rec solver xs =
    try find p xs with
    | NotFound -> solver (flat_map r xs)
  in if p x then x else solver (r x)
;;

(*
#8
solve_path : 'a rel -> 'a prop -> 'a -> 'a list 
behaves exactly as `solve` except that it produces not only the final value `y` such that `p y` but also all the intermediate elements from `x` to `y` that show how `x` is related to `y` through `r`.
*)
let solve_path r p x =
  let rec solver_acc acc x' =
    if p x' then acc @ [x']
    else acc @ [x'] @ (flat_map (solver_acc acc) (r x'))
  in
  solver_acc [] x
;;

(*
#9
archive_map : ('a, 'set) set_operations -> 'a rel -> ('set * 'a list) -> ('set * 'a list)
archive_map opset rel (s, l) = (s', l'), where:
  * l' is the list of elements that are reachable using rel from the elements of
    l and which are not already in the set s.
  * s' is the union of s and the elements of l'. 
*)
let archive_map opset r (s, l) =
  let l' = List.fold_left (fun acc el ->
      if opset.mem el s then acc
      else el::acc
    ) [] (flat_map r l)
  in let s' = List.fold_right opset.add l' s
  in
  (s', l')
;;

(*
#10
solve' : ('a, 'set) set_operations -> 'a rel -> 'a prop -> 'a -> 'a
explores the search space with no redundancy. Use `archive_map`
*)
let solve' opset r p x =
  let rec setfind (s, xs) =
    try find p xs with
    | NotFound -> setfind (archive_map opset r (s, xs)) 
  in
  if p x then x 
  else setfind (opset.empty,  (r x))
;;


(*
#11
solve_path' : ('a list, 'set) set_operations -> 'a rel -> 'a prop -> 'a -> 'a list
*)
let solve_path' opset r p x =
  let rec setfind_acc path x' =
    if p x' then path @ [x']
    else
      path @ [x'] @ (flat_map (setfind_acc path) (r x'))
  in
  setfind_acc [] x
  (* for some reason the below implementation is a type error: *)
  (*let rec setfind_path path (s, xs) =
  try path @ [find p xs]
  with NotFound -> setfind_path path (archive_map opset r (s, xs)) 
  in
  setfind_path [] (opset.empty, [x])
  *)
;;

klotski.prelude.ml

exception NotFound

type 'e rel = 'e -> 'e list
type 'e prop = 'e -> bool

type ('a, 'set) set_operations = {
  empty : 'set;              (* The empty set. *)
  mem : 'a -> 'set -> bool;  (* [mem x s = true] iff [x] is in [s]. *)
  add : 'a -> 'set -> 'set;  (* [add s x] is the set [s] union {x}. *)
}

type ('configuration, 'move) puzzle = {
  move : 'configuration -> 'move -> 'configuration;
  possible_moves : 'configuration -> 'move list;
  final : 'configuration -> bool
}

type piece_kind = S | H | V | C | X
type piece = piece_kind * int
let x = (X, 0) and s = (S, 0) and h = (H, 0)
let (c0, c1, c2, c3) = ((C, 0), (C, 1), (C, 2), (C, 3))
let (v0, v1, v2, v3) = ((V, 0), (V, 1), (V, 2), (V, 3))
let all_pieces : piece list = [ s; h; c0; c1; c2; c3; v0; v1; v2; v3 ]

type board = piece array array
let initial_board =
  [| [| v0 ; s  ; s  ; v1 |];
     [| v0 ; s  ; s  ; v1 |];
     [| v2 ; h  ; h  ; v3 |];
     [| v2 ; c0 ; c1 ; v3 |];
     [| c2 ; x  ; x  ; c3 |] |]

let initial_board_simpler =
  [| [| c2 ; s  ; s  ; c1 |] ;
     [| c0 ; s  ; s  ; c3 |] ;
     [| v1 ; v2 ; v3 ; v0 |] ;
     [| v1 ; v2 ; v3 ; v0 |] ;
     [| x  ; x  ; x  ; x  |] |]

let initial_board_trivial =
  [| [| x  ; s  ; s  ; x  |] ;
     [| x  ; s  ; s  ; x  |] ;
     [| x  ; x  ; x  ; x  |] ;
     [| x  ; x  ; x  ; x  |] ;
     [| x  ; x  ; x  ; x  |] |]

type direction = { dcol : int; drow : int; }
type move = Move of piece * direction * board
let move _ (Move (_, _, b)) = b