# Funkcyjne
## Lista 2
### z1

let my_length = List.fold_left (fun acc _ -> acc + 1) 0
let my_rev = List.fold_left (fun acc x -> x :: acc) [] 
let my_map f xs = List.fold.right (fun x acc -> f x :: acc) xs []
let my_filter f xs = List.fold_right (fun x acc -> if f x then x :: acc else acc) xs []
let my_rev_map f = List.fold_left (fun acc x -> (f x) :: acc) [] 

### z2

let rec sublists = function
  | []    -> [[]]
  | x::xs -> let ls = sublists xs in
               List.map (fun l -> x::l) ls @ ls;;
               
#### v2

let rec sublists xs = match xs with
				| [] -> [] 
				| x :: [] -> [[x]; []]
				| x :: xs -> let ys = sublists(xs)
					     in List.fold_left (fun acc y -> (x :: y) :: acc) ys ys

### z3

let rec sufiks xs = match xs with 
			| [] -> []
			| x :: [] -> [[x]; []]
			| x :: ys -> xs :: sufiks ys
            
let prefiks lista =  sufiks (List.rev lista);;

let rec prefix xs = match xs with 
			| [] -> []
			| x :: [] -> [[]; [x]]
			| x :: ys -> [] :: List.map (fun y -> x :: y ) (prefix ys)

### z4

:::spoiler nieważne
let rec insert cmp x xs = match xs with 
			| [] -> [x]
			| y :: ls ->  if cmp x y then x :: xs
				      else y :: insert cmp x ls 
			
let stupid_merge cmp xs ys = List.fold_left (fun ls x -> insert cmp x ls) ys xs
:::

# nieogonowe
let rec merge cmp l1 l2 = match (l1, l2) with
| [], a -> a
| a, [] -> a
| x :: xs, y :: ys -> 
        if cmp x  y then x :: merge cmp xs l2
                 else y :: merge cmp ys l1
else y :: merge cmp ys (x :: xs)

# ogonowe z odwracaniem
let merge_tail cmp lista1 lista2 = 
    let rec _merge cmp l1 l2 result = 
        match l1, l2 with
            | [] , [] -> result
            | [] , h :: t | h :: t , [] -> _merge cmp  [] t (h::result)
            | h1 :: t1 , h2 :: t2 -> if (cmp h1 h2) 
            then _merge cmp t1 l2 (h1::result) 
            else _merge cmp l1 t2 (h2::result) 
            in List.rev(_merge cmp lista1 lista2 []);;

let rec halve ls = match ls with
| [] -> [[]; []]
| a :: [] -> [[a]; []]
| a :: b :: ys -> let xs = halve ys in
        [(a :: List.hd xs); (b :: List.hd(List.tl xs))];;
        
        
let rec mergesort ls = match ls with
| [] -> []
| [a] -> [a]
| _ -> let xs = halve ls in
        merge (mergesort (List.hd xs)) (mergesort (List.hd (List.tl xs)));;
        
:::spoiler kornelia
let rec mergesort cmp xs = match xs with 
				| [] -> []
				| [x] -> [x]
				| xs -> let [ys;zs] = halve xs in merge cmp (mergesort cmp ys) (mergesort cmp zs)
:::

porownyywanie czasu
let time f x =
    let t = Sys.time() in
    let fx = f x in
    Printf.printf "Execution time: %fs\n" (Sys.time() -. t);
    fx
    
    
pd : time merge_tail (<=) [1;2;5;7;8] [3;4;7;10]

### z5

let merge_tail cmp reversed lista1 lista2 = 
    let rec _merge cmp l1 l2 result = 
        match l1, l2 with
            | [] , [] -> result
            | [] , h :: t | h :: t , [] -> _merge cmp  [] t (h::result)
            | h1 :: t1 , h2 :: t2 -> if (cmp h1 h2) == reversed
            then _merge cmp l1 t2 (h2::result) 
            else _merge cmp t1 l2 (h1::result)  
            in _merge cmp lista1 lista2 [];;
        
        
---------------- 
let merge_tail cmp lista1 lista2 = 
    let rec _merge cmp l1 l2 result = 
        match l1, l2 with
            | [] , [] -> result
            | [] , h :: t | h :: t , [] -> _merge cmp  [] t (h::result)
            | h1 :: t1 , h2 :: t2 -> if (cmp h1 h2)
            then _merge cmp l1 t2 (h2::result) 
            else _merge cmp t1 l2 (h1::result)  
            in _merge cmp lista1 lista2 [];;
            
let rec mergesort cmp xs = match xs with 
				| [] -> []
				| [x] -> [x]
				| _ -> let [ys;zs] = halve xs in merge_tail cmp (mergesort (fun a b -> not (cmp a b)) ys) (mergesort (fun a b -> not (cmp a b)) zs)
            

### z6

let rec insert x lst =
  match lst with
  | [] -> [[x]]
  | h::t -> 
    (x::lst) :: (List.map (fun el -> h::el) (insert x t));;



let rec perm lst =
  match lst with
  | [] -> [lst]
  | h::t -> 
    List.flatten (List.map (insert h) (perm t));;

::: spoiler Kornelia

(* przez wstawianie *)
let rec insert_everywhere xs y = match xs with 
					| [] -> [[y]]
					| x :: xs -> (y :: x :: xs) :: List.map (fun z -> x :: z) (insert_everywhere xs y)
                    
                    
let rec perms xs = match xs with
			| [] -> []
			| x :: [] -> [[x]]
			| x :: xs -> let ys = perms xs in List.flatten (List.map (fun s ->  insert_everywhere s x) ys)	
            
(* przez wybór *)
let rec perms2 ls = 
	let join x xs = match xs with
			| [] -> [[x]]
			| _ -> List.map (fun ys -> x :: ys) xs
	   in let rec inner ys acc = match ys with 
		| [] -> []
		| [y] -> join y (perms2 acc)
		| y :: ys -> let zs = perms2 (acc@ys) in (join y zs) @ (inner ys (y :: acc)) 
		in inner ls []

:::

### z7

  type ltree =
    | Leaf
    | Node of ltree * int * int * ltree

  let make lt1 lt2 v = match lt1, lt2 with 
    | Leaf, Leaf -> Node (lt1, v, 1, lt2)
    | Node (_, _, d1, _), Node (_, _, d2, _) -> if d2 < d1 then Node (lt1, v, d2 + 1, lt2) else Node (lt2, v, d1 + 1, lt1)
    | Leaf, Node (_, _, d, _)  -> Node (lt2, v, d + 1, lt1)
    | Node (_, _, d, _), Leaf ->  Node (lt1, v, d + 1, lt2)

let deep lt = match lt with
  | Leaf -> 0
  | Node(_, _, d, _) -> d

let rec join lt1 lt2 = match lt1, lt2 with 
    | Leaf, _ -> lt2
    | _, Leaf -> lt1 
    | Node (l1, v1, d1, r1), Node (l2, v2, d2, r2) -> if v2 < v1 then let lt_new = join r2 lt1 
        in if deep lt_new > deep l2 then Node (lt_new, v2, d1 + 1, l2)
                                    else Node (l2, v2, deep lt_new + 1, lt_new)
                                                                else join lt2 lt1

let add v lt = join lt (make Leaf Leaf v)

let del_min lt = match lt with 
  | Leaf -> Leaf
  | Node (l, _, _, r) -> join l r
  
let get_min lt = match lt with
  | Leaf -> failwith "empty"
  | Node (_, v, _, _) -> v

ze strony

type 'a leftist =  
  | Leaf 
  | Node of 'a leftist * 'a * 'a leftist * int
  
  
let singleton k = Node (Leaf, k, Leaf, 1)

let rank = function Leaf -> 0 | Node (_,_,_,r) -> r 

let rec merge t1 t2 =  
  match t1,t2 with
    | Leaf, t | t, Leaf -> t
    | Node (l, k1, r, _), Node (_, k2, _, _) ->
      if k1 > k2 then merge t2 t1 (* switch merge if necessary *)
      else 
        let merged = merge r t2 in (* always merge with right *)
        let rank_left = rank l and rank_right = rank merged in
        if rank_left >= rank_right then Node (l, k1, merged, rank_right+1)
        else Node (merged, k1, l, rank_left+1) (* left becomes right due to being shorter *)
        
let insert x t = merge (singleton x) t

let get_min = function  
  | Leaf -> failwith "empty"
  | Node (_, k, _, _) -> k

let delete_min = function  
  | Leaf -> failwith "empty"
  | Node (l, _, r, _) -> merge l r  
  

### z8 :(
### z9

type 'a clist = { clist : 'z. ('a -> 'z -> 'z) -> 'z -> 'z }

let cnil : = { clist = fun f z -> z}

let ccons a ls = {clist = fun f z -> f a (ls.clist f z)}

let map g ls = {clist = fun f z -> ls.clist (fun a s -> f (g a) s) z}

let append xs ys = {clist = fun f z -> xs.clist f (ys.clist f z)}

let clist_to_list ls = ls.clist List.cons [] 

let rec clist_of_list xs = match xs with 
  | [] -> cnil
  | x :: xs -> ccons x (clist_of_list xs)
  

To daje iloczyn kartezjański
let prod ls1 ls2 = ls1.clist (fun a1 z1 -> (ls2.clist (fun a2 z2 -> ccons (a1,a2) z2) z1)) cnil;;

Czy potrafisz zaimplementować funkcję analogiczną do potęgowania? NIE

## Lista 3

### z1

#### perm.ml

module type OrderedType = sig
    type t
    val compare : t -> t -> int
end

module type S = sig
    type key
    type t
    
    (** permutacja jako funkcja *)
    val apply : t -> key -> key
    
    (** permutacja identycznościowa *)
    val id : t
    
    (** permutacja odwrotna *)
    val invert : t -> t
    
    (** permutacja która tylko zamienia dwa elementy miejscami *)
    val swap : key -> key -> t
    
    (** złożenie permutacji (jako złożenie funkcji) *)
    val compose : t -> t -> t

    (** porównywanie permutacji *)
    val compare : t -> t -> int
end

module Make(Key : OrderedType) = struct
    module Ourmap = Map.Make(Key)
    type key = Key.t
    type t = key Ourmap.t * key Ourmap.t
    
    (** permutacja jako funkcja *)
    let apply (perm : t) (value : key) = 
        if Ourmap.mem value (fst perm) 
                        then Ourmap.find value (fst perm)
                        else value
    
    (** permutacja identycznościowa *)
    let id : t = (Ourmap.empty, Ourmap.empty)

    (** permutacja odwrotna *)
    let invert (perm : t) =
        (snd perm , fst perm)
        
    (** permutacja która tylko zamienia dwa elementy miejscami *)
    let swap (e1 : key) (e2 : key) = 
        let f = (Ourmap.add e1 e2 (Ourmap.add e2 e1 Ourmap.empty)) 
        in (f, f)
    
    
    (** złożenie permutacji (jako złożenie funkcji) BRZYDKIE *)
   (* val compose (perm1 : t) (perm2 : t) =
            let map1 = union (fun key v1 v2 -> v2) 
                            (fst perm2) 
                            (Ourmap.filter (fun k v -> Key.compare k v != 0) 
                                            (Ourmap.map (apply perm2) (fst perm1)))
            in (map1, map2 - odwrotnosc map1)
*)
                
        
 let compose (perm1 :t) (perm2 : t) = 
        (Ourmap.merge 
            (fun (k : key) (v1 : key option) (v2 : key option) -> 
                match v1,v2 with
                | None, None -> None
                | _, Some(v) -> let vi = apply perm1 v in
                                    if (Key.compare k vi == 0) then None
                                        else Some(vi)
                | Some(v), None -> Some(v)         
            ) 
            (fst perm1) (fst perm2),
        Ourmap.merge
            (fun (k : key) (v1 : key option) (v2 : key option) ->
                match v1,v2 with
                | None, None -> None
                | Some(v), _ -> let vi = apply (invert perm2) v in 
                                if (Key.compare k vi == 0) then None 
                                    else Some(vi)
                | None, Some(v) -> Some(v)
            )
            (snd perm1) (snd perm2)
        )

    (** porównywanie permutacji *)
    let compare (perm1 : t) (perm2 : t) = Ourmap.compare Key.compare (fst perm1) (fst perm2)
end

Testy:

module PermInt = Perm.Make(Int);;
let lista=[1;2;3;4];;
let perm1=PermInt.id
List.map (PermInt.apply perm1) lista
let perm2=PermInt.swap 2 4
List.map (PermInt.apply perm2) lista
List.map (PermInt.apply (PermInt.invert perm2)) lista


module PermInt = Perm.Make(Int);;
let lista=[1;2;3;4];;
let swap_23 = PermInt.swap 2 3;;   (*1 3 2 4*)
let swap_34 = PermInt.swap 3 4;; (*1 2 4 3*)
let swap_24 = PermInt.compose swap_23 swap_34;; (* 1 3 4 2*)
List.map (PermInt.apply swap_24) lista;;   
List.map (PermInt.apply (PermInt.invert swap_24)) lista;; (* 1 4 2 3 *)

let swap_32 = PermInt.swap 3 2;;
let my_id = PermInt.compose swap_23 swap_32;;
PermInt.compare my_id PermInt.id;; (* 0 *)


PermInt.compare()

- ocamlc -c perm.mli
- ocamlc -c perm.ml
- utop perm.cmo
W utopie :
- open Perm;;
- module PermInt = Perm.Make(Int);;

### z2

#### .mli

module type OrderedType = sig 
    type t
    val compare : t -> t -> int
end

module type Permutation = sig 
    type key
    type t
    (* permutacja jako funkcja *)
    val apply : t -> key -> key
    (* permutacja identycznosciowa *)
    val id : t
    (* permutacja odwrotna *)
    val invert : t -> t
    (* permutacja która zmienia dwa elementy miejscami *)
    val swap : key -> key -> t
    (* złożenie permutacji (jako złożenie funkcji) *)
    val compose : t -> t -> t
    (* porównanie permutacji *)
    val compare : t -> t -> int
  end

module type S = sig 
    type t
    (* czy dany element jest generowany przez zbior *)
    val is_generated : t -> t list -> bool
  end
  
  module Make(Perm : Permutation) : S with type t = Perm.t

#### .ml

module type OrderedType = sig 
    type t
    val compare : t -> t -> int
end

module type Permutation = sig 
    type key
    type t
    (* permutacja jako funkcja *)
    val apply : t -> key -> key
    (* permutacja identycznosciowa *)
    val id : t
    (* permutacja odwrotna *)
    val invert : t -> t
    (* permutacja która zmienia dwa elementy miejscami *)
    val swap : key -> key -> t
    (* złożenie permutacji (jako złożenie funkcji) *)
    val compose : t -> t -> t
    (* porównanie permutacji *)
    val compare : t -> t -> int
  end

module type S = sig 
    type t
    (* czy dany element jest generowany przez zbior *)
    val is_generated : t -> t list -> bool
end

module Make(Perm : Permutation) = struct
    type t = Perm.t
    module PermSet = Set.Make(Perm)

    let is_generated (perm : t) (perm_lst : t list) = 
      let s = PermSet.add Perm.id (PermSet.of_list perm_lst)  in
          let rec inner (perm : t) (perm_set : PermSet.t) = 
              if PermSet.mem perm perm_set then true
              else let next_set =
                  PermSet.fold (fun el acc -> 
                    PermSet.union acc 
                            (PermSet.add (Perm.invert el)
                                (PermSet.fold (fun ell acc-> 
                                                PermSet.add (Perm.compose el ell) acc )
                                            perm_set PermSet.empty)))
                                perm_set
                                perm_set
                  in if compare next_set perm_set == 0 then false 
                      else inner perm next_set
            in inner perm s      

end
          

ocamlc -c gen_perm.ml
utop perm.cmo gen_perm.cmo

Testy

open Perm;;
open Genperm;;

module PermInt = Perm.Make(Int);;
module GenpermInt = Genperm.Make(PermInt);;
GenpermInt.is_generated (PermInt.swap 2 3) [PermInt.swap 2 3];;
let swap_23 = PermInt.swap 2 3;; 
let swap_34=PermInt.swap 3 4;;
let swap_24 = PermInt.compose swap_34 swap_23;;
GenpermInt.is_generated swap_24 [swap_23;swap_34];;
GenpermInt.is_generated swap_24 [PermInt.swap 2 5 ;swap_34];;

### z3, z4, z5, z6 :-0

Logic.ml

type formula = 
| My_False
| Variable of string
| Implication of formula * formula

let rec string_of_formula f = match f with 
| My_False -> "⊥"
| Variable c -> c
| Implication(My_False, r) -> "⊥ -> " ^ string_of_formula r
| Implication(Variable c, r) -> c ^ " -> " ^ string_of_formula r
| Implication(l, r) -> "(" ^ string_of_formula l ^ ")" ^ " -> " ^ string_of_formula r

let pp_print_formula fmtr f =
  Format.pp_print_string fmtr (string_of_formula f)

type theorem = | Theorem of formula list * formula

let assumptions thm = match thm with 
| Theorem(a, c) -> a

let consequence thm = match thm with 
| Theorem(a, c) -> c

let pp_print_theorem fmtr thm =
  let open Format in
  pp_open_hvbox fmtr 2;
  begin match assumptions thm with
  | [] -> ()
  | f :: fs ->
    pp_print_formula fmtr f;
    fs |> List.iter (fun f ->
      pp_print_string fmtr ",";
      pp_print_space fmtr ();
      pp_print_formula fmtr f);
    pp_print_space fmtr ()
  end;
  pp_open_hbox fmtr ();
  pp_print_string fmtr "⊢";
  pp_print_space fmtr ();
  pp_print_formula fmtr (consequence thm);
  pp_close_box fmtr ();
  pp_close_box fmtr ()

let by_assumption f = Theorem([f],  f)

let imp_i f thm = Theorem(List.filter (fun x -> not(x = f)) (assumptions thm), 
        Implication(f, consequence thm))

let difference_of_lists xs ys =
  List.filter (fun x -> not (List.mem x ys)) xs
  
  let imp_e th1 th2 = match consequence th1 with
  | Implication(fi, f) -> if (fi = consequence th2)
      then Theorem(difference_of_lists (assumptions th1) (assumptions th2) @ assumptions th2, f)
      else failwith "not equal"
  | _ -> failwith "incorrect th1"

      
let bot_e f thm = match consequence thm with 
| My_False -> Theorem(assumptions thm, f)
| _ -> failwith "incorrect theorem"


(* ⊢ p → p*)

(*⊢ p → q → p*)
(*⊢ (p → q → r) → (p → q) → p → r*)
(*⊢ ⊥ → p*)


(*
open Logic;;
#install_printer pp_print_formula ;;
#install_printer pp_print_theorem ;;   
*)

W Logic.mli

type formula = 
  | Implication of formula * formula
  | Variable of string
  | MyFalse

### z7 :-|

(* ⊢ p → p*)
imp_i (Variable "p") (by_assumption (Variable "p"));;
(*⊢ p → q → p*)
imp_i (Variable "p") (imp_i (Variable "q") (by_assumption (Variable "p")));;
(*⊢ (p → q → r) → (p → q) → p → r*)
let pqrL = (Implication (Variable "p", Implication (Variable "q", Variable "r")))
let pqL = Implication (Variable "p", Variable "q")
let pqrT = by_assumption pqrL
let pT = by_assumption (Variable "p")
let qrT = imp_e pqrT pT
let pqT = by_assumption pqL
let qT = imp_e pqT pT
let rT = imp_e qrT qT
let prT = imp_i (Variable "p") rT 
let pqprT  = imp_i pqL prT
pqrpqprT = imp_i pqrL pqprT;;

(*⊢ ⊥ → p*)
imp_i My_False (bot_e (Variable "p") (by_assumption My_False));;
(imp_i (Variable "q") (by_assumption (Variable "p")))

## Lista 4
### zadanie 1

### zadanie 2

### zadanie 3-6
proof.ml

open Logic

type lbl_assump = (string * Logic.formula)
type incomplete_proof = 
  | Goal   of lbl_assump list * Logic.formula
  | IBot_e of lbl_assump list * Logic.formula * incomplete_proof
  | IImp_e of lbl_assump list * Logic.formula * incomplete_proof * incomplete_proof
  | IImp_i of lbl_assump list * Logic.formula * incomplete_proof
  | IComplete of Logic.theorem

type context = 
  | CEmpty
  | CGoal of lbl_assump list * Logic.formula
  | CBot_e of context * lbl_assump list * Logic.formula 
  | CImp_e of context * lbl_assump list * Logic.formula * incomplete_proof
  | CImp_i of context * lbl_assump list * Logic.formula 
  | CComplete of Logic.theorem

type proof = 
  | Complete of Logic.theorem
  | Incomplete of incomplete_proof * context

let proof g f =
  Incomplete (Goal(g, f), CEmpty)

let qed pf =
  match pf with
  | Complete(t) -> t
  | _ -> failwith "incompleted proof"

let goal pf =
  match pf with
  | Complete(t) -> None
  | Incomplete(ip, _) -> 
    match ip with
    | Goal (g, f) -> Some (g, f)
    | _ -> failwith "not a goal"


let rec goal_down incomplete_proof ctx = 
  match incomplete_proof with
  | Goal (g, f) -> Some(Incomplete(incomplete_proof, ctx))
  | IBot_e (g, f, i) -> goal_down i (CBot_e(ctx, g, f))
  | IImp_e (g, f, i1, i2) -> 
  begin
    match i1 with 
    | IComplete _ ->  goal_down i2 (CImp_e(ctx, g, f, i1))
    | _ -> goal_down i1 (CImp_e(ctx, g, f, i2))
  end
  | IImp_i (g, f, i) -> goal_down i (CImp_i(ctx, g, f))
  | IComplete (_) -> None

let rec goal_up incomplete_proof ctx = 
  match ctx with
  | CEmpty -> None
  | CGoal (g, f) -> failwith "surely won't happen"
  | CBot_e (ctx, g, f) -> goal_up (IBot_e(g, f, incomplete_proof)) ctx
  | CImp_e (ctx, g, f, i2) -> 
  begin
    match i2 with 
    | IComplete (_) -> goal_up (IImp_e(g, f, incomplete_proof, i2)) ctx
    | _ -> goal_down i2 (CImp_e(ctx, g, f, incomplete_proof))
  end
  | CImp_i (ctx, g, f) -> goal_up (IImp_i(g, f, incomplete_proof)) ctx
  | CComplete (_)-> None



let next pf =
  match pf with
  | Complete _ -> pf
  | Incomplete (ipf, ctx) -> 
    match goal_down ipf ctx with
    | None -> 
    begin
      match goal_up ipf ctx with
      | None -> failwith "You shouldn't be here"
      | Some pf -> pf
    end
    | Some pf -> pf


let intro name pf =
  match pf with
  | Complete _ -> failwith "ups"
  | Incomplete (ipf,ctx) -> 
    match ipf with
    | Goal (assm, Logic.Implication(f1, f2)) -> 
      Incomplete (IImp_i (assm, Logic.Implication(f1, f2), Goal((name, f1)::assm, f2)), ctx)
    | _ -> failwith "ups v2"

let apply f pf =
  

let apply_thm thm pf =
  (* TODO: zaimplementuj *)
  failwith "not implemented"

let apply_assm name pf =
  (* TODO: zaimplementuj *)
  failwith "not implemented"

let pp_print_proof fmtr pf =
  match goal pf with
  | None -> Format.pp_print_string fmtr "No more subgoals"
  | Some(g, f) ->
    Format.pp_open_vbox fmtr (-100);
    g |> List.iter (fun (name, f) ->
      Format.pp_print_cut fmtr ();
      Format.pp_open_hbox fmtr ();
      Format.pp_print_string fmtr name;
      Format.pp_print_string fmtr ":";
      Format.pp_print_space fmtr ();
      Logic.pp_print_formula fmtr f;
      Format.pp_close_box fmtr ());
    Format.pp_print_cut fmtr ();
    Format.pp_print_string fmtr (String.make 40 '=');
    Format.pp_print_cut fmtr ();
    Logic.pp_print_formula fmtr f;
    Format.pp_close_box fmtr ()

v2 (tylko zmienione funkcje)

type goal = lbl_assump list * Logic.formula
type proof = 
  | Complete of Logic.theorem
  | Incomplete of goal * context

let proof g f =
  Incomplete ((g, f), CEmpty)

let rec goal pf =
  match pf with
  | Complete(t) -> None
  | Incomplete(ip, _) -> Some(ip)

## Lista 5

### zadanie 1

let fib_f fib n =
if n <= 1 then n
else fib (n-1) + fib (n-2)

let rec fix f x = f (fix f) x

let fib = fix fib_f

let rec fix_with_limit n f x = 
  if (n != 0) 
    then f (fix_with_limit (n - 1) f) x 
    else failwith "Limit exceeded";;

let memo = Hashtbl.create 1000;;

let rec fix_memo f x = 
  match Hashtbl.find_opt memo (Hashtbl.hash x) with
  | Some c -> c
  | None -> let a = f (fix_memo f) x in
      begin
        Hashtbl.add memo (Hashtbl.hash x) a;
        a
      end

### zadanie 3

type 'a lazy_tree =
  | LazyNode of (unit -> 'a lazy_tree) * 'a * (unit -> 'a lazy_tree)

let rec lazy_fraction_tree a b c d =
  LazyNode (
    (fun () ->
        lazy_fraction_tree a b (a + c) (b + d)),
    (a + c, b + d),
    (fun () ->
        lazy_fraction_tree (a + c) (b + d) c d)
  )

### zadanie 4 rozwarstwia sie :(

type 'a dllist = 'a dllist_data lazy_t
and 'a dllist_data =
{ prev : 'a dllist;
  elem : 'a;
  next : 'a dllist
}

let prev : 'a dllist -> 'a dllist = 
  function xs -> (Lazy.force xs).prev

let elem : 'a dllist -> 'a = 
  function xs -> (Lazy.force xs).elem

let next : 'a dllist -> 'a dllist =
  function xs -> (Lazy.force xs).next

let rec of_list (xs : 'a list) : 'a dllist = 
  match xs with
  | [] -> failwith "empty list"
  | x :: [] -> let rec dd = lazy {prev = dd; elem = x; next = dd} in dd
  | x :: y :: [] ->  
    let rec ds = lazy {prev = dd; elem = x; next = dd}
      and
      dd = lazy {prev = ds; elem = y; next = ds} in ds
  | x :: xs ->    
    lazy {prev = of_list (begin match List.rev (x::xs) with 
                          | y :: ys -> y :: List.rev ys 
                          |_ ->  failwith "err" end); 
          elem = x; 
          next = of_list (xs @ x :: [])}  
                  
let xs = of_list [8;9;10]
let () = assert (elem xs = 8)
let () = assert (elem (prev (next xs)) = elem xs)
(*
let () = assert (prev (next xs) == xs) (*        :(       *)
*)

### zadanie 6

type 'a to_lazy =
  | Lazy of (unit -> 'a) 
  | Value of 'a
  | Evaluating

type 'a my_lazy = 'a to_lazy ref

let force : 'a my_lazy -> 'a =
  fun ml -> 
    match !ml with
    | Lazy f   -> 
      ml := Evaluating; 
      let v = f () in 
      ml := Value(v); 
      v 
    | Value v  -> v
    | Evaluating -> failwith "Evaluating"

let fix (f : 'a my_lazy -> 'a) : 'a my_lazy =
  let rec lazy_value = ref (Lazy (fun () -> f lazy_value)) in
  lazy_value    

type 'a lazy_list =
  | Nil
  | Cons of 'a * 'a lazy_list my_lazy

let hd : 'a lazy_list -> 'a =
  function
  | Nil -> failwith "Empty list"
  | Cons(x, _) -> x

let tl : 'a lazy_list -> 'a lazy_list =
  function
  | Nil -> failwith "Empty list"
  | Cons(_, xs) -> force xs

let rec nth : 'a lazy_list -> int -> 'a = 
  fun ll n -> 
    if n < 0 then failwith "Index out of bounds" 
    else 
      if n == 0 then hd ll
      else nth (tl ll) (n - 1)


let stream_of_ones : int lazy_list my_lazy = 
  fix (fun stream_of_ones -> Cons (1, stream_of_ones))

(*
  nth (force stream_of_ones) 5   
*)

### zadanie 7

type 'a to_lazy =
  | Lazy of (unit -> 'a) 
  | Value of 'a
  | Evaluating

type 'a my_lazy = 'a to_lazy ref

let force : 'a my_lazy -> 'a =
  fun ml -> 
    match !ml with
    | Lazy f   -> 
      ml := Evaluating; 
      let v = f () in 
      ml := Value(v); 
      v 
    | Value v  -> v
    | Evaluating -> failwith "Evaluating"

let fix (f : 'a my_lazy -> 'a) : 'a my_lazy =
  let rec lazy_value = ref (Lazy (fun () -> f lazy_value)) in
  lazy_value    

(* z7 ---------------------------------------------------- *)

type 'a lazy_list =
  | Nil
  | Cons of 'a * 'a lazy_list my_lazy

let rec nth xs n =
  match xs with
  | Nil -> raise Not_found
  | Cons(x, xs) ->
    if n = 0 then x
    else nth (force xs) (n-1)

let rec filter (p : 'a -> bool) (xs : 'a lazy_list) : ('a lazy_list) = 
  match xs with
  | Nil                  -> Nil
  | Cons(x, xs) when p x -> Cons(x, ref (Lazy (fun () -> (filter p (force xs)))))
  | Cons(_, xs)          -> filter p (force xs)

let rec take_while p xs =
  match xs with
  | Cons(x, xs) when p x -> Cons(x, ref (Lazy (fun () -> (take_while p (force xs)))))
  | _ -> Nil

let rec for_all p xs =
  match xs with
  | Nil -> true
  | Cons(x, xs) -> p x && for_all p (force xs)

let rec nats_from n = 
  Cons(n, ref (Lazy (fun () -> (nats_from (n+1)))))
let nats = nats_from 0

let rec primes =
  Cons(2, ref (Lazy (fun () -> (filter is_prime (nats_from 3)))))
and is_prime n =
  primes
  |> take_while (fun p -> p * p <= n)
  |> for_all (fun p -> n mod p <> 0)

### zadanie 8

open Seq
type _ fin_type =
  | Unit : unit fin_type
  | Bool : bool fin_type
  | Pair : 'a fin_type * 'b fin_type -> ('a * 'b) fin_type

  let rec all_values : type a. a fin_type -> a Seq.t =
    fun ftype -> match ftype with
    | Unit -> List.to_seq [()]
    | Bool -> List.to_seq [true; false]
    | Pair (fst_type, snd_type) ->
      flat_map
        (fun fst_val ->
           map (fun snd_val -> (fst_val, snd_val))
                (all_values snd_type))
        (all_values fst_type)

### zadanie 9

type _ fin_type =
| Unit : unit fin_type
| Bool : bool fin_type
| Pair : 'a fin_type * 'b fin_type -> ('a * 'b) fin_type
| Empty : empty fin_type
| Either : 'a fin_type * 'b fin_type -> ('a, 'b) Either.t fin_type
and empty = |

let rec all_values : type a. a fin_type -> a Seq.t =
  function
  | Unit -> List.to_seq [()]
  | Bool -> List.to_seq [true; false]
  | Pair (a, b) -> 
    Seq.flat_map 
      (fun x -> 
        Seq.map 
          (fun y -> (x, y)) 
          (all_values b))
      (all_values a)
  | Empty -> Seq.empty
  | Either (a, b) -> 
    let av = all_values a and bv = all_values b in
    Seq.append 
      (Seq.map (fun x -> Either.left x) av)
      (Seq.map (fun y -> Either.right y) bv)

### zadanie 10

module Seq = struct
  include Seq
  let rec for_all : ('a -> bool) -> 'a Seq.t -> bool =
    fun pred seq ->
      match seq () with
      | Seq.Nil -> true
      | Seq.Cons (x, xs) -> pred x && for_all pred xs
  let is_empty seq =
    match seq () with
    | Seq.Nil -> true
    | _ -> false
end

type _ fin_type =
| Unit : unit fin_type
| Bool : bool fin_type
| Pair : 'a fin_type * 'b fin_type -> ('a * 'b) fin_type
| Empty : empty fin_type
| Either : 'a fin_type * 'b fin_type -> ('a, 'b) Either.t fin_type
| Function : 'a fin_type * 'b fin_type -> ('a -> 'b) fin_type
and empty = |

let rec all_values : type a. a fin_type -> a Seq.t =
  function
  | Unit -> List.to_seq [()]
  | Bool -> List.to_seq [true; false]
  | Pair (a, b) -> 
    Seq.flat_map 
      (fun x -> 
        Seq.map 
          (fun y -> (x, y)) 
          (all_values b))
      (all_values a)
  | Empty -> Seq.empty
  | Either (a, b) -> 
    let av = all_values a and bv = all_values b in
    Seq.append 
      (Seq.map (fun x -> Either.Left x) av)
      (Seq.map (fun y -> Either.Right y) bv)
  | Function (a, b) -> 
    all_functions a Seq.empty (all_values a) (all_values b)
      
and equal_at : type a. a fin_type -> a -> a -> bool =
  fun ty x y ->
    match ty with
    | Unit -> x = y
    | Bool -> x = y
    | Pair (a, b) ->
      equal_at a (fst x) (fst y) && 
      equal_at b (snd x) (snd y)
    | Empty -> true 
    | Either (a, b) ->
      (match (x, y) with
      | (Left x, Left y) -> equal_at a x y
      | (Right x, Right y) -> equal_at b x y
      | _ -> false)
    | Function (a, b) ->
      let all_inputs = all_values a in
      Seq.for_all (fun input -> equal_at b (x input) (y input)) all_inputs

and all_functions : type a b. a fin_type -> (a -> b) Seq.t -> a Seq.t -> b Seq.t -> (a -> b) Seq.t  =
  fun t seq a b ->
  match a () with
  | Seq.Nil -> seq
  | Seq.Cons (a, xs) -> 
    let seq =
    if Seq.is_empty seq then
      Seq.map (fun b -> fun _ -> b) b
    else 
      Seq.flat_map 
        (fun f -> 
          Seq.map (fun b -> 
            fun x -> if (equal_at t x a) then b
            else f x) b)
        seq
    in all_functions t seq xs b 

(* test *)
let xs = all_values (Function(Bool, Bool))
let ys = Seq.map (fun x -> List.map (fun y -> x y) (List.of_seq (all_values Bool))) xs 
let ls = List.of_seq ys

 

## Lista 6

### zadanie 1

type ('a, 'b) format = (string -> 'b) -> string -> 'a

let int (k : string -> 'a) = 
  fun (s : string) (i : int) -> k (s ^ (string_of_int i))

let str (k : string -> 'a) = 
  fun (s1 : string) (s2 : string) -> k (s1 ^ s2)
  
let lit (sn : string) (k : string -> 'a) = 
  fun (s : string) -> k(s ^ sn)

let (^^) (f1 : ('a, 'b) format) (f2 : ('b, 'c) format) (k : string -> 'c) =
  f1(f2 k)

let ksprintf (f : ('a, 'b) format) (k : string -> 'b) = 
  f k ""

let sprintf (f : ('a, string) format) =
  ksprintf f (fun x -> x);;

sprintf (lit "Ala ma " ^^ _int ^^ lit " kot" ^^ _str ^^ lit ".") 5 "ów"

### zadanie 2

### zadanie 3

exception Error of string

let for_all pred ls =
        try List.fold_left (fun acc a -> if not (pred a) then raise (Error "oops") else acc) true ls with Error _ -> false

let mult_list ls =
        try List.fold_left (fun acc a -> if a==0 then raise (Error "mult") else acc*a) 1 ls with Error _ ->0

let sorted ls=
        try fst(List.fold_left (fun acc a ->
                                        if a < snd(acc)
                                        then raise (Error "unsort")
                                        else (true, a))
                                (true, (List.hd ls))
                                (List.tl ls))
        with Error _ -> false

### zadanie 4

let rec fold_left_cps f acc xs=
        match xs with 
        | []    -> acc
        | x::xs -> f acc x (fun lacc -> fold_left_cps f lacc xs)

let fold_left f acc xs=
      fold_left_cps (fun acc x k -> k (f acc x)) acc  

### zadanie 5

let for_all pred xs =
        fold_left_cps (fun acc x k ->
                        if pred x
                        then k acc
                        else false
                        ) true xs

let mult_list xs = 
        fold_left_cps (fun acc x k ->
                        if x==0
                        then 0
                        else k (acc * x)
        ) 1 xs
let sorted xs =
        fold_left_cps (fun acc x k ->
                        if x>snd(acc)
                        then k (true,x)
                        else (false,x)
        ) (true,(List.hd xs)) (List.tl xs)
        |> fst

## Lista 7

### zadanie 1, 2

module type RandomMonad = sig
  type 'a t
  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
  val random : int t
  end

module RS : sig 
  include RandomMonad 
  val run : int -> 'a t -> 'a
end = struct
  type 'a t = int -> 'a * int
  let return x seed = (x, seed) 
  let run seed f = fst (f seed)
  let random a = 
    let b = 16807 * (a mod 127773) - 2836 * (a / 127773) in
    if b > 0 then (b, b) else (b + 2147483647, b + 2147483647)
  (* (x : int -> 'a * int) (f : 'a -> int -> 'b * int) -> (int -> 'b * int) *)
  let bind x f = 
    fun s1 -> let (v, s2) = x s1 in
    f v s2
end

module Shuffle(R : RandomMonad) : sig
  val shuffle : 'a list -> 'a list R.t
end = struct
  let rec chosen_rest idx xs = 
    match xs with
    | [] -> failwith "empty list"
    | x :: xs -> 
      if idx = 0 then (x, xs)
      else let (v, xs) = chosen_rest (idx - 1) xs in
      (v, x :: xs) 
  let rec shuffle xs = 
    match xs with
    | [] -> R.return []
    | _ -> 
      R.bind 
        R.random 
        (fun r -> let idx = r mod List.length xs in
        let (hd, tl) = chosen_rest idx xs in
        R.bind (shuffle tl) (fun shuffled_tl -> R.return (hd :: shuffled_tl)))
end

(*
  module SH = Shuffle(RS);;
  RS.run 0 (SH.shuffle [1;2;3;4;5;6;7;8]);;
  RS.run 23 (SH.shuffle [1;2;3;4;5;6;7;8]);;

  RS.run 1 (RS.bind RS.random (fun x -> RS.return (RS.run x RS.random)));;
*)

### zadanie 3

module IdMonad : sig
  type 'a t
  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
end = struct
  type 'a t = 'a
  let return x = x
  let bind x f = f x
end

module DeferredMonad : sig
  type 'a t
  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
end = struct
  type 'a t = unit -> 'a
  let return x = fun () -> x
  let bind x f = f (x ())
end

### zadanie 4
#### er

  module type Monad = sig
    type 'a t
    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
  end
  
  module Err : sig
    include Monad
    val fail : 'a t
    val catch : 'a t -> (unit -> 'a t) -> 'a t
    val run : 'a t -> 'a option
  end = struct
    type 'r ans = 'r option
    type 'a t = { run :  ('a -> 'a ans) -> 'a ans }
  
    let run m = m.run (fun a -> Some a)
    let return x = {run = fun cont -> cont x}
    let fail = {run = fun _ -> None}
  
    let bind m f =
      { run = fun cont ->
          match run m with
          | None -> None
          | Some x -> (f x).run cont }
  
    let catch m f =
  { run = fun cont ->
      match run m with
      | Some x -> Some x
      | None -> (f ()).run cont }

  end
  
  Err.run (Err.bind (Err.return 1) (fun x -> Err.return (x+1)));;

#### bt

  module type Monad = sig
    type 'a t
    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
  end
  
  module BT : sig
    include Monad
    val fail : 'a t
    val flip : bool t
    val run : 'a t -> 'a Seq.t
  end = struct
    type 'r ans = 'r Seq.t
    type 'a t = { run :  ('a -> 'a ans) -> 'a ans }
  
    let run m = m.run (fun a -> List.to_seq [a])
    let return x = {run = fun cont -> cont x}
    let fail = {run = fun _ -> Seq.empty}
    let flip = 
      { run = fun cont -> 
        Seq.flat_map cont (List.to_seq [true; false]) }


    let bind m f =
      { run = fun cont ->
          Seq.flat_map (fun a -> (f a).run cont) (run m) }
    
  end
  
  let (let* ) = BT.bind

let rec select a b =
  if a >= b then BT.fail
  else
    let* c = BT.flip in
    if c then BT.return a
    else select (a+1) b

let triples n =
  let* a = select 1 n in
  let* b = select a n in
  let* c = select b n in
  if a*a + b*b = c*c then BT.return (a, b, c)
  else BT.fail
 

  module type Monad = sig
    type 'a t
    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
  end
  
  module St(State : sig type t end) : sig
    include Monad
    val get : State.t t
    val set : State.t -> unit t
    val run : State.t -> 'a t -> 'a
  end = struct
    type 'a ans = State.t -> 'a * State.t
    type 'a t = { run : 'r. ('a -> 'r ans) -> 'r ans }

    let return x = {run = fun cont -> cont x}
  
    let run s m = fst (m.run (fun a s2 -> (a, s2)) s)

    let set s = {
      run = fun cont _ -> cont () s
    }

    let get = {
      run = fun cont s -> cont s s
    }


    let bind m f ={
      run = fun cont -> 
        m.run (fun a -> (f a).run cont)
    }
    
  end
  
  module CounterState = struct
    type t = int
  end
  
  module CounterMonad = St(CounterState)
  
  open CounterMonad
  
  let increment_and_get : int t =
    bind get (fun current_count ->
      bind (set (current_count + 1)) (fun () ->
        return current_count
      )
    )
  
  let example () =
    let initial_state = 0 in
    let result = run initial_state increment_and_get in
    Printf.printf "Final Counter Value: %d\n" result
  
  (* Run the example *)
  let () = example ()
  

### Zadanie 5

type 'a regexp =
  | Eps
  | Lit of ('a -> bool)
  | Or of 'a regexp * 'a regexp
  | Cat of 'a regexp * 'a regexp
  | Star of 'a regexp

let ( +% ) r1 r2 = Or(r1, r2)
let ( *% ) r1 r2 = Cat(r1, r2)

(** Obliczenia z nawrotami *)
module BT : sig
  type 'a t

  val return : 'a -> 'a t
  val bind   : 'a t -> ('a -> 'b t) -> 'b t

  (** Brak wyniku *)
  val fail : 'a t
  (** Niedeterministyczny wybór -- zwraca true, a potem false *)
  val flip : bool t

  val run : 'a t -> 'a Seq.t
end = struct
  (* Obliczenie typu 'a to leniwa lista wszystkich możliwych wyników *)
  type 'a t = 'a Seq.t

  let return x = List.to_seq [ x ]
  let rec bind m f = Seq.flat_map f m

  let fail = Seq.empty
  let flip = List.to_seq [ true; false ]

  let run m = m
end

let rec match_regexp (regex : 'a regexp) (xs : 'a list) : 'a list option BT.t =  
  match regex, xs with
  | Eps, [] -> BT.return None
  | Eps, xs -> BT.return (Some xs)
  | Lit _, [] -> BT.fail
  | Lit p, x :: xs -> 
    if p x then BT.return (Some xs)
    else BT.fail
  | Or (r1, r2), _ ->
    BT.bind BT.flip (fun flip_opt ->
      if flip_opt then match_regexp r1 xs else match_regexp r2 xs)
  | Cat (r1, r2), _ -> 
    BT.bind (match_regexp r1 xs) (fun result -> 
      match result with
      | Some x -> match_regexp r2 x
      | None -> match_regexp r2 xs)
  | Star r, _ -> BT.bind (match_regexp r xs) (fun res ->
      match res with
        | Some ys -> BT.bind BT.flip (fun flip_opt ->
          if flip_opt then BT.return (Some ys)
          else match_regexp (Star r) ys)
        | None -> BT.fail)

        (* | Star r, _ ->
          BT.bind BT.flip (fun flip_opt ->
            if flip_opt then
              BT.return None
            else
              match_regexp (Cat (r, Star r)) xs) *)
      
(*
   List.of_seq 
         (BT.run 
             (match_regexp
                      (Lit ((<>) 'a')) 
                      ['b';'c']));;

   List.of_seq 
         (BT.run 
             (match_regexp
                      (Star (Lit ((<>) 'o'))) 
                      ['s';'a';'k';'o';'p']));;

   List.of_seq 
    (BT.run 
        (match_regexp
                (Star (Star (Lit ((<>) 'k')))) 
                ['x';'a';'k']));;
  List.of_seq 
    (BT.run 
        (match_regexp
                (Star (Star (Lit ((<>) 'b')) +% (Lit ((=) 'b') *% Lit ((=) 'a')))) 
                ['s';'a';'k';'o';'p']));;

  Or działa z potencjalnymi duplikatami, stary też ale bez None
*)

### Zadanie 6

module SBT(State : sig type t end) : sig
    type 'a t
    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val fail : 'a t
    val flip : bool t
    val get : State.t t
    val put : State.t -> unit t
    val run : State.t -> 'a t -> 'a Seq.t
  end = struct
    type 'a t = State.t -> ('a * State.t) Seq.t
    let return x s = List.to_seq [(x, s)]
    let flip s = List.to_seq [(true, s); (false, s)]
    let get s = List.to_seq [(s, s)]
    let put s1 _ = List.to_seq [((), s1)]
    let fail _ = Seq.empty 
    let run s m = Seq.map (fun x -> fst x) (m s)
    let bind m f s = 
      Seq.flat_map (fun x -> f (fst x) (snd x)) (m s)
  end

### zadanie 8

type symbol = string

type 'v term =
| Var of 'v
| Sym of symbol * 'v term list

let return (a: 'v): 'v term =
  Var(a)

let rec bind (a: 'v term) (f: 'v -> 'v term): 'v term = 
  match a with
  | Var v -> f v
  | Sym (sym, terms) -> Sym(sym, List.map (fun t -> bind t f) terms)

## Lista 8
### zadania ?-?, trochę działa

{-# LANGUAGE LambdaCase #-}
import Data.Char (toLower)
import System.IO (isEOF)

main :: IO ()
main = putStrLn ":)"

-- z1 
echoLower :: IO ()
echoLower = do
    input <- getLine
    if not (null input)
    then do
        putStrLn $ map Data.Char.toLower input
        echoLower
    else
        return ()

-- z2
data StreamTrans i o a
    = Return a
    | ReadS (Maybe i -> StreamTrans i o a)
    | WriteS o (StreamTrans i o a)

toLower :: StreamTrans Char Char ()
toLower =
    ReadS $ \case
        Just c -> WriteS (Data.Char.toLower c) Main.toLower
        Nothing -> Return ()

runIOStreamTrans :: StreamTrans Char Char a -> IO a
runIOStreamTrans (Return a) = return a
runIOStreamTrans (ReadS f) = do
    input <- getChar
    if input == '\n'
        then runIOStreamTrans (f Nothing)
        else do
            runIOStreamTrans (f (Just input))
runIOStreamTrans (WriteS o st) = do
    putChar '\n' 
    putChar o
    putChar '\n' 
    runIOStreamTrans st

-- z3
listTrans :: StreamTrans i o a -> [i] -> ([o], a)
listTrans (Return a) xs = ([], a)
listTrans (ReadS f) [] = listTrans (f Nothing) []
listTrans (ReadS f) (x:xs) = listTrans (f (Just x)) xs
listTrans (WriteS o cont) xs =
  let (output, result) = listTrans cont xs
  in (o : output, result)

-- z6

catchOutput :: StreamTrans i o a -> StreamTrans i b (a, [o])
catchOutput (Return a) = return (a, [])
catchOutput (ReadS f) = do
    input <- getChar
    if input == '\n'
        then catchOutput (f Nothing)
        else do
            catchOutput (f (Just input))
catchOutput (WriteS o st) = 
    catchOutput ( ReadS $ \case
        Just c -> WriteS (o : c : []) st
        Nothing -> Return ()) 



-- z7

data BF
    = MoveR     -- >
    | MoveL     -- <
    | Inc       -- +
    | Dec       -- -
    | Output    -- .
    | Input     -- ,
    | While [BF]-- [ ]

brainfuckParser :: StreamTrans Char BF ()
brainfuckParser =     
    ReadS $ \case
        Just c -> WriteS (parse c) brainfuckParser
        Nothing -> Return ()

parse :: Char -> BF
parse '>' = MoveR
parse '<' = MoveL
parse '+' = Inc
parse '-' = Dec
parse ',' = Input
parse '.' = Output