module type KWICConnection = sig
  type input
  type out
  val run : input -> out
end

module PassthroughConnection (Input : sig type t end) = struct
  type input = Input.t
  type out = Input.t
  let run s = s
end

module type KWICModule = sig
  type input
  type out

  val init : (unit -> 'a) option
  val run : input -> out
end

module PassthroughModule (InConn : KWICConnection) (OutConn : KWICConnection) (*: KWICModule*) = struct
  type input = InConn.out
  type out = OutConn.input

  let init = None
  let run s = s
end

module type KWICStorage = sig
  type value
  type index
  
  val init : (unit -> 'a) option
   val add : value -> index 
(*  val get : index -> value*)
(*  val set : index -> value -> unit*)
  val swap : index -> index -> unit
  val compare : index -> index -> bool
  val getAll : unit -> string list
  val nextIndex : (index option) -> index
  val maxIndex : unit -> index
(*   val intValue : int -> value *)
end

module type Value = sig
  type value
end

module type ExtValue = sig
  type value
(*   val intValue : int -> value *)
  val valueString : value -> string 
end

(* signature makes type value abstract, and cannot be resolved to int 
   by compiler *)
module ListStorage (Value : ExtValue) (*: KWICStorage*) = struct 
  open List
  type value = Value.value
  type index = int
  
  let core = ref []
  let init = None
(*   let intValue = Value.intValue *)
  let add v = core := v ::
     !core; (length !core)
  let get i = nth !core ((length !core) - i)
  let set i v = 
    let rec replace i v l n =
        match l with
          [] -> [] (*can't replace anything in empty list*)
         | h :: t -> 
            if i <= n then 
              (if i = n then v else h) :: replace i v t (n-1)
            else l
(*    in let rec add i v l n = 
      if i = n + 1 then
        v :: l
      else add i v (intValue 0 :: l) (n+1)*)
    in core := (*if i > length !core then add i v !core (length !core) else*) replace i v !core (length !core)
  let swap i1 i2 = let tmp = get i1 in set i1 (get i2); set i2 tmp
  let compare i1 i2 = get i1 < get i2
  let getAll () = map Value.valueString !core
  let nextIndex n = match n with
    None -> 1
   |Some n -> n+1
  let maxIndex () = length !core
end
(* Going too far with 'look how inefficient it is and yet it still works'; untested
module ListStorage2 (Value : sig type value val intValue : int -> value val valueString : value -> string end) : KWICStorage = struct
  open List
  type value = Value.value
  type index = value list

  let core = ref []
  let init = None
  let intValue = Value.intValue
  (*let get (h::t) = h
  let set (h::t) v = v::t
  let swap (h1::t1) (h2::t2) = set (h1::t1) h2; set (h2::t2) h1 *)
  let get i = 
    let rec getrec i l = match i with
      l -> hd !core
     |_ -> getrec i (if length l > 1 then tl l else raise (Failure "index does not match storage"))
   in getrec i !core
  let set i v = 
    let rec replace i v l =
        match l with
          [] -> []
         |h :: t -> match i with
            l -> v::t
           |_ -> h::replace i v t
    in core := replace i v !core
  let swap i1 i2 = let tmp = get i1 in set i1 (get i2); set i2 tmp
  let compare i1 i2 = get i1 < get i2
  let getAll () = map Value.valueString !core
  let nextIndex i = match i with
    None -> (nth !core ((length !core) -1))::[]
   |Some i -> let rec findNext i (h::t) prev =
      match i with
        [] -> []
       |l  -> match prev with
          None   -> i (*maxIndex reached*)
         |Some v -> v::h::t
       |_  -> findNext i t (Some h)
      in findNext i !core None
  let maxIndex () = !core
end*)

module type BubbleSortList = sig
  type elt
  val bubblesort : elt list -> elt list
end

module BubbleSortListModule (*: BubbleSortList*) = struct
  open List
  type elt = int
  let rec bsiteration s = match s with
    x :: x2 :: xs -> if x < x2 then 
                       x :: (bsiteration (x2::xs)) 
                     else 
                       x2 :: (bsiteration (x::xs))
   |s             -> s
  let rec bubblesort s = 
    let ss = bsiteration s in 
    if s = ss then s else bubblesort ss
end

module type BubbleSortArray = sig
  type elt
  val bubblesort : elt array -> elt array
end

module BubbleSortArrayModule (* BubbleSortArray *) = struct
  open Array
  type elt = int
  
  let swap s i1 i2 = let tmp = s.(i1) in s.(i1) <- s.(i2); s.(i2) <- tmp
  let rec bsiteration s n = 
    if n + 1 < length s then ( (* parentheses for clarity *)
      if s.(n) > s.(n+1) then (
        swap s n (n+1)
      );
      bsiteration s (n+1)
    )
  let rec bubblesort s = let ss = copy s in bsiteration s 0; if ss = s then s else bubblesort s
end

(*module type Sort = sig
  val sort : unit
end*)

module BubbleSort (Storage : KWICStorage)  (* : Sort *) = struct
  let rec bsiteration n = 
    let swapped = ref false in
    let m = Storage.nextIndex (Some n) in 
    if m <= Storage.maxIndex () then ( (* parentheses for clarity *)
      if (Storage.compare n m) then ( (* must not be true when equal! *)
        Storage.swap n m;
        swapped := true
      )
    );
    if m < Storage.maxIndex () then (
      let otherswapped = bsiteration m in
        if otherswapped && (!swapped = false) then swapped := true
    );
    !swapped
    
  let rec bubblesort () = let swapped = bsiteration (Storage.nextIndex None) in if swapped then bubblesort () else ()
  let getAll = Storage.getAll
end

module type KWICStorageG = functor (V : Value) -> sig
  type value = V.value
  type index
  type vlrc = V.value list ref code (* maybe list could be another parameter *)
  
  val add : vlrc -> V.value code -> index code
  val get : vlrc -> index code -> V.value code
  val swap : vlrc -> index code -> index code -> unit code
  val compare : vlrc -> index code -> index code -> bool code
  val nextIndex : (index code option) -> index code
  val maxIndex : value list code -> index code
end

(* tried to solve Container signature mismatch to no avail *)
module type KWICStorageG2 = sig
  type index
  type value
  type vlrc = value list ref code (* maybe list could be another parameter *)
  
  val add : vlrc -> value code -> index code
  val get : vlrc -> index code -> value code
  val swap : vlrc -> index code -> index code -> unit code
  val compare : vlrc -> index code -> index code -> bool code
  val nextIndex : (index code option) -> index code
  val maxIndex : value list code -> index code
end

module ListStorageG (Value : Value) (* : KWICStorageG *) = struct
  open Runcode
  open List
(*   type value = Value.value *)
  type value = Value.value
  type index = int
  type vlrc = Value.value list ref code
  
(*   let intValue = Value.intValue *)
  let add core v = .< begin .~core := .~v :: ! .~core; length ! .~core end >.
  let get core i = .< nth ! .~core ((length ! .~core) - .~i) >.
  let set core i v = 
    let rec replace i v l n = (*n could be length l*)
        match l with
          [] -> .<[]>.
         |h :: t ->
(*             if i <= n then *)
              .< .~ (if i = n then .<(v)>. else .<h>.) :: (.~ (replace i v t (n-1))) >.
(*             else .<l>. *)
    in .< core := .~ (replace i v !core (length !core)) >.
  let swap core i1 i2 =
    let rec swap_ i1 i2 pre mid post l =
      let biggest = max i1 i2 in
      let smallest = min i1 i2 in
      let rec assemble pre mid post =
        match mid with
          [] -> (match pre with
            [] -> post
           |hp::tp -> assemble tp [] (hp::post))
         |hm::tm -> assemble pre tm (hm::post)
      in match l with
        [] -> assemble pre mid post
       |h :: t when length l > biggest -> swap_ i1 i2 (h::pre) mid post t
       |h :: t when length l = biggest -> swap_ i1 i2 pre mid [h] t
       |h :: t when length l < biggest && length l > smallest -> swap_ i1 i2 pre (h::mid) post t
       |h :: t when length l = smallest -> swap_ i1 i2 pre (mid @ [h]) post t
       |lst -> assemble pre mid (post @ lst)
     in .< .~core := swap_ .~i1 .~i2 [] [] [] ! .~core >.
  let compare core i1 i2 = .< .~(get core i1) < .~(get core i2) >.
  let nextIndex = function
    None -> .<1>.
   |Some n -> .<.~n + 1>.
  let maxIndex core = .<length .~core>.
end

(* A sorter requires orderable elements in a container that retains order *)
module GnomeSortGenerator (V : Value) (S : KWICStorageG)  (* : Sort *) = struct
  open Runcode
  module Storage = S(V)
  
  let genrecloop core gen rtarg = .<let rec loop j = .~(gen core .<loop>. .<j>.) in loop .~rtarg>.
  
  let gsiteration core o (n : Storage.index code) = 
    let m = Storage.nextIndex (Some n) in 
    let maxI = Storage.maxIndex .< ! .~core >. in
    .<
      if .~m <= .~maxI then ( (* parentheses for clarity *)
        if .~(Storage.compare core n m) then ( (* must not be true when equal! *)
          .~(Storage.swap core n m);
          true
        ) else .~m < .~maxI && .~o .~m
     ) else false
    >.
  
  let gs core o n = .<
    if .~(genrecloop core gsiteration n) = true then
      .~o .~n (*no need to increment n, always examining entire list*)
    else ()
  >.
  
  let gnomesort core = (genrecloop core gs (Storage.nextIndex None))
end

(*A word must at least be orderable*)
(*module type Word = sig
  type value
  val lessthan : value -> value -> bool
end*) (*thinking aloud*)

(* A line must be orderable and rotatable *)
module type LineG = functor (C: KWICStorageG) (W : Value) -> sig
  module Container : KWICStorageG2 with type value = W.value
(*To work as a Value in KWICStorageG, must have type value; ideally KWICStorageG cannot be nested directly*)
  type value = W.value list
  
  val rotate : value ref code -> unit code
end

module ListStorageLineG = functor (C : KWICStorageG) (W : Value) -> struct
  module Container = C (W)
  type value = W.value list
  
  let genrecloop gen rtarg = .<let rec loop j = .~(gen .<loop>. .<j>.) in loop .~rtarg>.
  
  let rotate (core : value ref code) = 
    let r o i = 
      let m = Container.nextIndex (Some i) in
      .<
        if .~i < .~(Container.maxIndex .< ! .~core >. ) then (
          .~(Container.swap core i m);
          .~o .~m
        ) else ()
      >. in
    genrecloop r (Container.nextIndex None)
end

module Shifter (V : Value) (S1 : KWICStorageG) (S2 : KWICStorageG) = struct
  open List
  module Storage1 = S1 (V)
  module Storage2 = S2 (V)
  (*assuming value is a list of something*)
  let rotate (h::t) = t @ [h]
  let all_rotations l =
    let rec ar (h::t) =
      if (length (h::t)) < (length h) then ar ((rotate h)::h::t)
      else (h::t) in
    ar (l::[])
end

module type ShifterG = functor (V: Value) (L : LineG) (LS : KWICStorageG) (S1 : KWICStorageG) (S2 : KWICStorageG) -> sig
  type vlr1c
  type vlr2c
  val shift : vlr1c -> vlr2c ->  unit code
end

module ListStorageShifterG (V: Value) (LS : KWICStorageG) (L : LineG) (S1 : KWICStorageG) (S2 : KWICStorageG) = struct
  module Line = L (LS) (V)
  module Storage1 = S1 (Line)
  module Storage2 = S2 (Line)
  type vlr1c = Storage1.vlrc
  type vlr2c = Storage2.vlrc
  
  let genrecloop gen rtarg = .<let rec loop j = .~(gen .<loop>. .<j>.) in loop .~rtarg>.

  let add_all_rotations core (line : Line.value ref code) = 
    let orig = line in
    let add_rotation o (ll : Line.value ref code) = 
      let l = .< ! .~ll >. in
      .< begin
      .~(Line.rotate ll);
      if .~ll <> .~orig then ( (*cannot use !=, not same ref (==); for contents use = and <> *)
        ignore ( .~(Storage2.add core l ));
        .~o .~ll
      )
    end >. in .< begin
    ignore ( .~(Storage2.add core .< ! .~line >. ));
    .~(genrecloop add_rotation line ) end >.

  let shift core1 core2 =
    let shiftline o i = 
      let line = Storage1.get core1 i in .<
      if .~i <= .~(Storage1.maxIndex .< ! .~core1 >.) then (
        .~(add_all_rotations core2 .<ref .~line>.);
        .~o .~(Storage1.nextIndex (Some i))
      ) >. in
    genrecloop shiftline (Storage1.nextIndex None)
      
end

(* Testing *)
module IntV (*: ExtValue*) = struct
  type value = int
  let intValue n = n
  let valueString v = string_of_int v
end

module StringV (*: Value*) = struct
  type value = string
end

module LineV (*: Value*) = struct
  type value = string list
end

module IntListStorage = ListStorage (IntV)

module ILBS = BubbleSort (IntListStorage)

module ILBSG = GnomeSortGenerator (IntV) (ListStorageG)

module SLGSG = GnomeSortGenerator (StringV) (ListStorageG)

module Utils = struct
  let print_list f lst =
    let rec print_elements = function
      | [] -> ()
      | h::t -> f h; print_string ";"; print_elements t
    in
    print_string "[";
    print_elements lst;
    print_string "]"
end

open OUnit2
open Runcode
module Test = struct
  open List
(*   non-generator test-cases *)
  module ILBS0 = BubbleSort (ListStorage (IntV))
  let test0 = 
    ILBS0.bubblesort(); 
    assert_equal [] (ILBS0.getAll ())
  
  module IL1 = ListStorage (IntV)
  module ILBS1 = BubbleSort (IL1)
  let test1 =
    ignore (IL1.add 5); (*returns unused index, but that's ok *)
    ILBS1.bubblesort();
    assert_equal ["5"] (ILBS1.getAll ())
  
  module IL2 = ListStorage (IntV)
  module ILBS2 = BubbleSort (IL2)
  let test2 = 
    ignore (IL2.add 3);
    ignore (IL2.add 8);
    ILBS2.bubblesort();
    assert_equal ["3"; "8"] (ILBS2.getAll ())
  
  module IL3 = ListStorage (IntV)
  module ILBS3 = BubbleSort (IL3)
  let test3 = 
    ignore (IL3.add 7);
    ignore (IL3.add 2);
    ignore (IL3.add 9);
    ILBS3.bubblesort();
    assert_equal ["2"; "7"; "9"] (ILBS3.getAll ())
  
  module IL2e = ListStorage (IntV)
  module ILBS2e = BubbleSort (IL2e)
  let test2e = 
    ignore (IL2e.add (2)); 
    ignore (IL2e.add (2));
    ILBS2e.bubblesort();
    assert_equal ["2"; "2"] (ILBS2e.getAll ())

(*   Generator test cases *)

  module ILGa2 = ListStorageG (IntV)
  let testilga2 =
    let c = .< 
    let core = ref [] in begin
    ignore ( .~(ILGa2.add .<core>. .< 5 >.) );
    ignore ( .~(ILGa2.add .<core>. .< 3 >.) );
    map string_of_int !core end >. in
    begin
    Print_code.print_code Format.std_formatter c;
    print_newline ();
    Utils.print_list print_string (!. c);
    assert_equal ["3"; "5";] (!. c)
    end
  module ILGmi2 = ListStorageG (IntV)
  let testilgmi2 =
    let c = .<
    let core = ref [] in begin
    ignore ( .~(ILGmi2.add .<core>. .< 5 >.) );
    ignore ( .~(ILGmi2.add .<core>. .< 3 >.) );
    .~(ILGmi2.maxIndex .<! core>. ) end >. in
    assert_equal 2 (!. c)

  module ILGni0 = ListStorageG (IntV)
  let testilgni0 =
    let c = .< .~(ILGni0.nextIndex None) >. in
    assert_equal 1 (!. c)

  module ILGni2 = ListStorageG (IntV)
  let testilgni2 =
    let c = .< .~(ILGni2.nextIndex (Some (ILGni2.nextIndex (Some (ILGni2.nextIndex None))))) >. in
    assert_equal 3 (!. c)

  module ILGc2 = ListStorageG (IntV)
  let testilgc2 =
    let c = .< 
      let core = ref [] in
      .~ (ILGc2.compare .<core>. (ILGc2.add .<core>. .< 5 >.) (ILGc2.add .<core>. .< 3 >.) ) >. in
    assert_equal false (!. c)

  module ILGs2 = ListStorageG (IntV)
  let testilgs2 =
    let c = .< 
    let core = ref [] in begin
    let i1 = .~(ILGc2.add .<core>. .<5>.) in
    let i2 = .~(ILGc2.add .<core>. .<3>.) in
    ignore (.~(ILGc2.swap .<core>. .<i1>. .<i2>.));
    map string_of_int !core end >. in
    begin
    Print_code.print_code Format.std_formatter c;
    print_newline ();
    Utils.print_list print_string (!. c);
    assert_equal ["5"; "3"] (!. c)
    end


  module ILBSG0 = GnomeSortGenerator (IntV) (ListStorageG)
  let testg0 = 
    let c = .<
      let core = ref [] in begin
        .~(ILBSG0.gnomesort .<core>.);
        !core end >. in
    assert_equal [] (!. c)

  module ILG1 = ListStorageG (IntV)
  module ILBSG1 = GnomeSortGenerator (IntV) (ListStorageG)
  let testg1 = 
    let c = .< 
      let core = ref [] in begin
        ignore ( .~(ILBSG1.Storage.add .<core>. .< 5 >.));
        .~(ILBSG1.gnomesort .<core>.);
        map string_of_int !core end >. in
      assert_equal ["5"] (!. c)

  module ILG2e = ListStorageG (IntV)
  module ILBSG2e = GnomeSortGenerator (IntV) (ListStorageG)
  let testg2e = 
    let c = .<
      let core = ref [] in begin
        ignore ( .~(ILBSG2e.Storage.add .<core>. .<2>.)); 
        ignore ( .~(ILBSG2e.Storage.add .<core>. .<2>.));
        .~(ILBSG2e.gnomesort .<core>.);
        map string_of_int !core end >. in
    assert_equal ["2"; "2"] (!. c)

  module ILBSG3 = GnomeSortGenerator (IntV) (ListStorageG)
  let testg3 =
    let c = .<
      let core = ref [] in begin
        ignore ( .~(ILBSG3.Storage.add .<core>. .<3>.));
        ignore ( .~(ILBSG3.Storage.add .<core>. .<2>.));
        ignore ( .~(ILBSG3.Storage.add .<core>. .<4>.));
        .~(ILBSG3.gnomesort .<core>.);
        map string_of_int !core end >. in
    assert_equal ["2"; "3"; "4"] (!. c)

  module SLGSG3 = GnomeSortGenerator (StringV) (ListStorageG)
  let testsg = 
    let c = .<
      let core = ref [] in begin
        ignore ( .~(SLGSG3.Storage.add .<core>. .<"quad">.));
        ignore ( .~(SLGSG3.Storage.add .<core>. .<"erad">.));
        ignore ( .~(SLGSG3.Storage.add .<core>. .<"demo">.));
        .~(SLGSG3.gnomesort .<core>.);
        !core end >. in
    assert_equal ["demo"; "erad"; "quad"] (!. c)
    
(*   line rotate test *)
  module SLSLG1 = ListStorageLineG (ListStorageG) (StringV)
  let testsl = 
    let c = .<
      let core = ref [] in begin
        ignore ( .~(SLSLG1.Container.add .<core>. .<"quad">.));
        ignore ( .~(SLSLG1.Container.add .<core>. .<"erad">.));
        ignore ( .~(SLSLG1.Container.add .<core>. .<"demo">.));
        .~(SLSLG1.rotate .<core>.);
        !core end >. in
    assert_equal ["quad"; "demo"; "erad"] (!. c) (*rotate moves last word to front*)
(* the test case that breaks everything   *)
  module SLSG1 = ListStorageShifterG (StringV) (ListStorageG) (ListStorageLineG) (ListStorageG) (ListStorageG)

  let testsl = 
    let c = .<
      let line1 = ref [] in
      let core1 = ref [] in
      let core2 = ref [] in begin
        ignore ( .~(SLSG1.Line.Container.add .<line1>. .<"face">.));
        ignore ( .~(SLSG1.Line.Container.add .<line1>. .<"hand">.));
        ignore ( .~(SLSG1.Storage1.add .<core1>. .<! line1>.));
        .~(SLSG1.shift .<core1>. .<core2>.);
        !core2 end >. in
    assert_equal [["face"; "hand"]; ["hand"; "face"]] (!. c)
end
;;
(* test cases: no numbers, one number, two numbers, three numbers, list with two equal numbers, *)