Kody 3

open List;;
open Find_Union;;
open Fifo;;

let buduj_permutacje ll =
    fold_left
        (fun f l -> if l = [] then f else
            fold_left
                (fun (f, prev) a ->
                    (fun x ->
                        if x = prev then a
                        else f x
                    ), a
                )
            (f, hd (rev l)) l |> fst
        )
        (fun x -> x) ll

(***** 19.11.2018 *****)

(* zadanie słupki (tzw Rolki papieru) *)

let slupki l =
    let l = List.sort compare l in
    let m = List.nth l ((length l) / 2) in
    fold_left (fun a x -> a + abs (m - x)) 0 l

(* to nie wiem jakie zadanie *)

let element lx ly =
    let rec chodz i lx lyj a =
        match lyj with
        | [] -> a
        | (y, j)::tyj ->
            if i = y then
                chodz i lx ((j, hd lx)::a) tyj
            else (
                assert (i < y);
                chodz (i + 1) (tl lx) a lyj )
    in ly |> mapi (fun j y -> (y, j)) |> sort compare |> chodz 0 lx [] |> sort compare |> map snd

(* zadanie oi, czy istnieje trojka indeksow parami roznych i,j,k ze xi, xj, xk spelniaja nierownosc trojkata *)
(* posortowac i sprawdzac kolejne trzy *)

(***** 26.11.2018 *****)

(* zadanie katastrofy lotnicze (??) *)

let katastrofy l =
    let rec pom l i s a = (* lista, indeks y_i, schodki, rev lista k_i *)
        match l with
        | [] -> rev a
        | xi::tl ->
            let e = (i, xi) in
            match s with
            | [] -> pom tl (i + 1) (e::s) (i::a)
            | (j, xj)::ts ->
                if xi < xj then
                    pom tl (i + 1) (e::s) ((i - j)::a)
                else pom l i ts a
    in pom l 1 [] []

(* 28.11.2018 *)

type 'a option = None | Some of 'a
type 'a elem = {v : 'a; mutable next : 'a lista}
and 'a lista = 'a elem option

let x = Some {v = 0; next = None}

(* petla : 'a lista -> unit *)

let petla l =
    if l = None then ()
    else
        let get o =
            match o with
            | Some x -> x
            | None -> assert false in
        let cur = ref l in
        let next = ref ((get l).next) in
        while !next <> None do
            let e = get !next in
            let n = e.next in
            e.next <- !cur;
            cur := !next;
            next := n
        done;
        (get l).next <- !cur

(* module counter, cos w nim nie dziala 100 linijka  *)

(*
module type COUNTER =
sig
    type counter
    val make : unit -> counter
    val inc : counter -> int
    val reset : unit -> unit
end
module Counter : COUNTER =
struct
    let time = ref 0 in
    type counter = {mutable value : int; mutable update_time : int}
    let make () = {value = 0; update_time = !time}
    let reset () = incr time
    let inc c =
        if c.update_time <> !time then
            (c.value <- 1; c.update_time <- !time)
        else
            c.value <- c.value + 1;
        c.value
end
*)

(***** 3.12.2018 *****)

(* zadanie bitfony *)
(* cykl : int array -> int *)

let cykl p =
    let n = Array.length p in
    let v = Array.make n false in
    let rec obejdz i dl =
        if v.(i) then dl else (v.(i) <- true; obejdz p.(i) (dl + 1)) in
    let max_dl = ref 0 in (
    for i = 0 to n - 1 do
        max_dl := max (obejdz i 0) (!max_dl)
    done;
    !max_dl)

(* zadanie fastrygi (??) *)
(* fastryguj : 'a drzewo -> unit *)
(* chodzi chyba o to zeby zrobic przejscie in order *)

type 'a drzewo =
    | Puste
    | Wezel of 'a drzewo * 'a * 'a drzewo * 'a drzewo ref

let ignore x = let _ = x in ()

let fastryguj t =
    let rec pom t next =
        match t with
        | Puste -> next
        | Wezel (l, _, p, r) -> (
            r := pom p next;
            pom l t
        )
    in ignore (pom t Puste)

(* tu cos nie dziala *)


let fastryguj t =
    let next = ref Puste in
    let rec invinfix t =
        match t with
        | Puste -> ()
        | Wezel (l, _, p, r) -> (
            invinfix p;
            r := !next;
            next := t;
            invinfix l
        )
    in invinfix t


(* Napisz funkcję fastryga 'a drzewo -> unit, która poustawia referencje w wierzchołkach tak,
   aby wierzchołki o tej samej wartości tworzyły listę cykliczną. *)

type 'a drzewo =
    | Puste
    | Wezel of 'a drzewo * 'a * 'a drzewo * 'a drzewo ref

(*
let fastryga t =
    let poprz = ref Puste in
    let rec infix t =
        match t with
        | Puste -> ()
        | Wezel (l, x, p, r) ->
            infix l;
            (match !poprz with
            | Puste -> r := t
            | Wezel (_, y, _, s) ->
                if x = y then
                    (r := !s; s := t)
                else
                    r := t;)
            poprz := t;
            infix p;
    in infix t
*)

(***** 5.12.2018 *****)

(* zadanie skarbonki *)

(* n skarbonek z kluczykami o numerach 0, ..., n - 1                                *)
(* a - tablica rozmiaru n                                                           *)
(* a.(i) - numer skarbonki, w której znajduje się kluczyk do skarbonki i          *)
(* Oblicz minimalną liczbę skarbonek, które trzeba rozbić, aby otrzymać wszystkie  *)
(* jakies proste find & union, liczba spojnych składowych                          *)

let skarbonki a =
    let n = Array.length a in
    let s = Array.init n (fun i -> make_set i) in
    for i = 0 to n - 1 do
        union s.(i) s.(a.(i))
    done;
    n_of_sets ()

(* zadanie wieże *)

(* chyba (int * int) list zmieniamy na (int * int) * ((int * int) set) *)
(* jakieś kolejne na find & union *)
(* wieże różnych kolorów nie mogą się ze sobą szachować *)

let kolory l =
    let p = map (fun w -> (w, make_set w)) l in
    let lacz sel =
        let p = List.sort (fun a b -> compare (a |> fst |> sel) (b |> fst |> sel)) p in
        let rec pom p =
            match p with
            | (wa, sa)::(wb, sb)::_ ->
                if sel wa = sel wb then
                    union sa sb;
                    pom (tl p)
            | _ -> () in
        pom p in
    lacz fst;
    lacz snd;
    n_of_sets ()

(***** 10.12.2018 *****)

(* jakieś zadanie na imperatywne                                                       *)
(* jest jakiś kod i zobaczyć co on robi                                               *)
(* zwraca pierwszą większą liczbę fibonnaciego od [n], która jest na parzystym miejscu     *)

let coto n =
    let x = ref 0 in
    let y = ref 1 in
    while !y <= n do
        x := !x - !y;
        y := !y - !x
    done;
    !y

(* zadanie na grafy, jest plansza m x n ze skrzyżowaniami na przecięciach     *)
(* nie można skręcać w lewo                                              *)

let kpk ulice =
    let north = 0 and east = 1 and south = 2 and west = 3 in
    let m = Array.length ulice in
    let n = Array.length ulice.(0) in
    let kier = [|(0, 1); (1, 0); (0, -1); (-1, 0)|] in
    let (++) (x, y) (a, b) = (x + a, y + b) in
    let visited = Array.init m
        (fun _ -> Array.init n (fun _ -> Array.make 4 (-1))) in
    let fifo = ref empty in
    fifo := insert !fifo (0, 0, 0);
    visited.(0).(0).(0) <- 0;
    while not (is_empty !fifo) do
        let (i, j, k) = front !fifo in
        fifo := remove !fifo;
        for d = 0 to 1 do
            let k' = (k + d) mod 4 in
            let (i', j') = (i, j) ++ kier.(k') in
            if visited.(i').(j').(k') < 0 then (
                visited.(i').(j').(k') <- visited.(i).(j).(k) + 1;
                fifo := insert !fifo (i', j', k'))
        done
    done;
    visited.(m - 1).(n - 1).(east)

(***** 12.12.2018 *****)

(*
    A - amortyzowane
    B - referencje, tablice, proste imperatywne
    C - struktury wskaźnikowe
    D - fastrygi na drzewie
    E - find-union
    F - logika
*)

(* zadanie rejs, ktos chce poplynac na [k] dni                      *)
(* jakis kolega ma wolny czas w przedziale a_i, b_i                 *)
(* kiedy wyruszyć w rejs żeby mogli żeglować jak największą grupą    *)


(*
type zdarzenie =
    | Pocz
    | Kon

let rejs k l =
    let lz = (* lista zdarzeń *)
        map (fun (a, b) -> [(a, Pocz); (b, Kon)]) l |> flatten |> sort compare in (* flatten [[x, y, z];[a, b, c]] = [x, y, z, a, b, c] *)
    let sprawdz r = (* czy >= r kolegów da się zabrać *)
        let rec pom lz ilu ost_t = (* ost_t od ost_t mamy r kolegów - int option *)
            match lz with
            | [] -> false
            |


(* binsercz *)

let l = ref 0
and p = ref (length l) in
while !l < !p do
    let m = (!l + !p) / 2 in
    if sprawdz m then l := m
    else p := m - 1
done;
!l
*)


(* zadanie jakies z teorii gier na f&u) *)
(* hex : int -> (int * int) list -> (int * bool), kiedy i kto wygrał *)


(***** 17.12.2018 *****)

(*  8. Dany jest acykliczny graf skierowany (DAG). Jego wierzchołki są ponumerowane od 0 do n,           *)
(*  a krawędzie są dane w postaci tablicy sąsiedztwa (kwadratowej tablicy e wartości logicznych;        *)
(*  w grafie mamy krawędź u→v wtw., gdy e.(u).(v) ). Powiemy, że wierzchołek u dominuje wierzchołek v,    *)
(*  jeżeli dla każdego wierzchołka w, z którego można dojść do v, z u można dojść do w.                  *)
(*                                                                                                      *)
(*  Napisz procedurę zdominowani : bool array array -> int, która na podstawie tablicy opisującej graf    *)
(*  obliczy liczbę wierzchołków, dla których istnieją wierzchołki je dominujące.                        *)

open Array;;

let zdominowani e =
    let n = length e in
    let indeg v =
        let wyn = ref 0 in
        for u = 0 to n - 1 do
            if e.(u).(v) then incr wyn
        done;
        !wyn in
    let visited = make n 0 in
    let rec dfs v =
        if visited.(v) < 2 then begin
            visited.(v) <- visited.(v) + 1;
            for u = 0 to n - 1 do
                if e.(v).(u) then dfs u
            done
        end in
    for v = 0 to n - 1 do
        if indeg v = 0 then dfs v
    done;
    fold_left (fun acc x -> if x < 2 then acc + 1 else acc) 0 visited

(* T(n) = 0(n^2) *)
(* M(n) = 0(n) *)


(***** 19.12.2018 *****)

(*  10. [XIV OI, zadanie Powódź] Dana jest mapa topograficzna miasta położonego w kotlinie,                      *)
(*  w postaci prostokątnej tablicy typu (int * bool) array array. Liczby określają wysokość                       *)
(*  kwadratów jednostkowych, a wartości logiczne określają, czy dany kwadrat należy do terenu miasta.         *)
(*  Przyjmujemy, że teren poza mapą jest położony wyżej niż jakikolwiek kwadrat na mapie.                        *)
(*  Miasto zostało całkowicie zalane. Żeby je osuszyć należy w kotlinie rozmieścić pewną liczbę pomp.           *)
(*  Każda z pomp wypompowuję wodę aż do osuszenia kwadratu jednostkowego, na którym się znajduje.               *)
(*  Osuszenie dowolnego kwadratu pociąga za sobą obniżenie poziomu wody lub osuszenie kwadratów jednostkowych,  *)
(*  z których woda jest w stanie spłynąć do kwadratu, na którym znajduje się pompa.                              *)
(*  Woda może przepływać między kwadratami, które stykają się bokami.                                          *)
(*                                                                                                              *)
(*  Wyznacz minimalną liczbę pomp koniecznych do osuszenia miasta.                                              *)
(*  Teren nie należący do miasta nie musi być osuszony. Miasto nie musi tworzyć spójnego obszaru.             *)


(*
let powodz teren =
    let m = length teren in
    let n = length teren.(0) in
    let l = ref [] in
    for i = 0 to m - 1 do
        for j = 0 to n - 1 do
            if snd teren.(i).(j) then
                l := (fst teren.(i).(j), (i, j))::!l
        done
    done;
    l := List.sort compare !l;
    let spompowane = make_matrix m n false in
    let kolejka = ref Leftist.empty in
    let pompy = ref [] in
    while !l <> [] do
        if Leftist.is_empty !kolejka || fst (Leftist.get_min !kolejka) > fst (hd !l) then begin
            let (wys, (i, j)) = hd !l in
            l := tl !l;
            if not spompowane.(i).(j) then begin
                pompy := (i, j)::(!pompy);
                spompowane.(i).(j) <- true;
                kolejka := Leftist.add (wys, (i, j)) !kolejka
            end
        end
        else begin
            let (wys, (i, j)) = Leftist.get_min !kolejka in
            kolejka := Leftist.remove_min !kolejka;
            if not spompowane.(i).(j) then
                spompowane.(i).(j) <- true;
        end
        let splywaj i' j' wys =
            if not spompowane.(i').(j') then begin
                if not snd teren.(i').(j') || fst teren.(i').(j') >= wys then
                    kolejka := Leftist.add (max wys (fst teren.(i').(j'), (i', j'))) !kolejka
            end in
        if i > 0 then splywaj (i - 1) j wys;
        if i < m - 1 then splywaj (i + 1) j wys;
        if j > 0 then splywaj i (j - 1) wys;
        if j < n - 1 then splywaj i (j + 1) wys;
    done;
    !pompy
*)

(* Zadanie jakieś na BackTracka, jest plansza [m] x [n], jest skoczek i jakies skoki jego *)

let skoczek m n =
    let d = [|(2, 1); (2, -1); (-2, 1); (-2, -1); (1, 2); (1, -2); (-1, 2); (-1, -2)|] in
    let a = make_matrix m n (-1) in
    let rec bt x y k =
        if 0 <= x && x < m && 0 <= y && y < n then
            if k = m * n && x = 0 && y = 0 then
                failwith "Yeah!"
            else if a.(x).(y) < 0 then begin
                a.(x).(y) <- k;
                Array.iter (fun (dx, dy) -> bt (x + dx) (y + dy) (k + 1)) d;
                a.(x).(y) <- -1
        end in
    try
        bt 0 0 0; a
    with _ -> a

(***** 7.01.2019 *****)

(* Chyba zwykły problem wydawania reszty *)

let reszta n l =
    let a = Array.init (n + 1) (fun i -> if i = 0 then 0 else n + 1) in
    List.iter
        (fun b ->
            for i = b to n do
                a.(i) <- min a.(i) (a.(i - b) + 1)
            done
        ) l;
    a.(n)

(* T(n, m) = O(n * m)   *)
(* M(n, m) = O(n)       *)

(* Na ile sposobów możemy wydać daną resztę *)

let reszta n l =
    let a = Array.init (n + 1) (fun i -> if i = 0 then 1 else 0) in
    List.iter
        (fun b ->
            for i = b to n do
                a.(i) <- a.(i) * a.(i - b) (* na tablicy był tu + ??? *)
            done
        ) l;
    a.(n)

(*
let banknot n l =
    let a = Array.init (n + 1) (fun i -> if i = 0 then 0 else n + 1) in
    List.iter
        (fun (b, c) ->
            for r = 0 to b - 1 do
                let kolejka = ref KMinQ.init c in
                for q = 1 to (n - r) / b do
                    kolejka := KMinQ.add (a.(q + b + r) - q) !kolejka;
                    a.(q * b + r) <- (KMinQ.get_min !kolejka) + q
                done
            done
        ) l;
    a.(n)
*)

(* T(n, m) = O(n * m)   *)
(* M(n, m) = O(n)       *)

(***** 9.01.2019 *****)

let klej l =
    let x = Array.of_list l in
    let n = Array.length x in
    let s = Array.make (n + 1) 0 in
    for i = 1 to n do
        s.(i) <- s.(i - 1) + x.(i - 1)
    done;
    let dl a b =
        s.(b + 1) - s.(a) in
    let m = Array.make_matrix n n max_int in
    for a = 0 to n - 1 do
        m.(a).(a) <- 0
    done;
    for d = 1 to n - 1 do
        for a = 0 to n - d - 1 do
            let b = a + d in (* m.(a).(b) *)
            for i = a to b - 1 do
                m.(a).(b) <- min m.(a).(b) (m.(a).(i) + m.(i + 1).(b) + max (dl a i) (dl (i + 1) b))
            done
        done
    done;
    m.(0).(n - 1)

(* T(n) = O(n^3) *)
(* M(n) = O(n^2) *)

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

(* Nie działa intersect *)
(*
let rownowaga t =
    let przetnij a b =
        let rec pom a b acc =
            match a, b with
            | x::t, y::s ->
                if x < y then pom t b acc
                else if x > y then pom a s acc
                else pom t s (x::acc)
            | _ -> rev acc in
        pom a b [] in
    let rec dynamik t =
        match t with
        | Leaf -> (0, [0])
        | Node (w, l, p) ->
            let (u, a) = dynamik l in
            let (v, b) = dynamik p in
            let uv =
                if u >= 0 && v >= 0 && u = v then u + v + 1
                else -1 in
            let c = intersect a b |> map (fun x -> x + w + 1) in (* map ((+) (w + 1)) *)
            (uv, if uv >= 0 then uv::c else c) in
    (dynamik t |> snd) <> []

*)

(* nlog n czas i pamiec *)