module List =
    /// A map function with additional state
    let mapp f state lst =
        let rec mapp_aux f state lst acc =
            if List.is_empty lst then
                List.rev acc
            else
                let elem, state = f (List.hd lst) state
                mapp_aux f state (List.tl lst) (elem :: acc)
        mapp_aux f state lst []


let split elem acc =
    match acc with
    | []        -> [[elem]]
    | (1::_)::_ -> [elem] :: acc
    | h::t      -> (elem :: h) :: t


let next_char c =
    char (int c + 1)


let rename elem (hash, ch) =
    if hash |> Map.mem elem then
        (hash.[elem], (hash, ch))
    else
        (ch, (hash |> Map.add elem ch, next_char ch))


let a = [1;6;7;8;1;8;7;4;3;2;1;6;7;8;1;6;5;1;9;1;6;5;1;6;7;8;1;9;1;9;1;6;7;8;1;3]
let b = List.fold_right split a [] |> List.mapp rename (Map.empty, 'A')
// b = [A; B; A; C; D; C; A; D; D; A; E]

>let trans l =
  let h = HashMultiMap.Create() and i = ref 64 in
  let _,l' = List.fold_right (fun x (tmp,acc) -> if x=1 then [],(x::tmp)::acc else (x::tmp),acc) l ([],[]) in
  List.map (fun x -> match h.TryFind x with Some v -> v | None -> incr i; let c = char_of_int !i in h.Add(x,c); c) l';;
val trans : int list -> char list

>trans [1; 6; 7; 8; 1; 8; 7; 4; 3; 2; 1; 6; 7; 8; 1; 6; 5; 1; 9; 1; 6; 5; 1; 6; 7; 8; 1; 9; 1; 9; 1; 6; 7; 8; 1; 3];;
val it : char list = ['A'; 'B'; 'A'; 'C'; 'D'; 'C'; 'A'; 'D'; 'D'; 'A'; 'E']

let sublists = f ((=) 1) input

let unique xs = xs |> Set.of_list |> Set.to_list

let answer = 
  let lookup = unique sublists
  List.map (fun x -> List.find_index ((=) x) lookup) sublists

let f p xs = 
  let f xs = 
    match xs with
    | [] -> None
    | x::xs' -> let ys, zs = break p xs'
                Some (x::ys, zs)
  unfold f xs

let unfold f x =
  let rec unfold' x acc =
    match f x with
    | None -> List.rev acc
    | Some (a, x') -> unfold' x' (a::acc)
  unfold' x []
    
let break p xs = 
  let rec break' xs acc =
    match xs with
    | [] -> List.rev acc, []
    | x::_ when p x -> List.rev acc, xs
    | x::xs' -> break' xs' (x::acc)
  break' xs []

#light

let input = [1; 6; 7; 8; 1; 8; 7; 4; 3; 2; 1; 6; 7; 8; 1; 6; 5; 1; 9; 1; 6; 5; 1; 6; 7; 8; 1; 9; 1; 9; 1; 6; 7; 8; 1; 3]

printfn "input = %A" input

let foldFunc i acc =
    if acc = [] then
        [ [ i ] ]
    elif List.hd (List.hd acc) = 1 then
        [ i ] :: acc
    else
        (i :: (List.hd acc)) :: (List.tl acc)

// Break it down into sub lists starting with 1
let orgSubLists = List.fold_right foldFunc input [] 

// Make them unique..
let subLists = orgSubLists |> Set.of_list |> Set.to_list

printfn "sub lists = %A" subLists

// Now reduce the origional 
let reduceList list subLists =
    let rec reduceListr list subLists seenSoFar resultsSoFar =
        if list = [] then
            resultsSoFar
        else
            let result = List.tryfind_index (fun subList -> subList = seenSoFar) subLists
            if Option.is_none result then
                reduceListr (List.tl list) subLists (seenSoFar @ [List.hd list]) resultsSoFar
            else
                reduceListr list subLists [] (resultsSoFar @ [Option.get result])
    reduceListr list subLists [] []

let reducedList = reduceList input subLists

printfn "reduced list (indexes) = %A" reducedList

// Now make the results meaningful...
List.iteri (fun i subList -> printfn "%c = %A" (char (65 + i)) subList) subLists

let letteredAnswer = List.map (fun i -> char (65 + i)) reducedList
printfn "Answer = %A" letteredAnswer

(* Output

input = [1; 6; 7; 8; 1; 8; 7; 4; 3; 2; 1; 6; 7; 8; 1; 6; 5; 1; 9; 1; 6; 5; 1; 6; 7; 8; 1;

 9; 1; 9; 1; 6; 7; 8; 1; 3]

sub lists = [[1; 3]; [1; 6; 5]; [1; 6; 7; 8]; [1; 8; 7; 4; 3; 2]; [1; 9]]

reduced list (indexes) = [2; 3; 2; 1; 4; 1; 2; 4; 4; 2]

A = [1; 3]

B = [1; 6; 5]

C = [1; 6; 7; 8]

D = [1; 8; 7; 4; 3; 2]

E = [1; 9]

Answer = ['C'; 'D'; 'C'; 'B'; 'E'; 'B'; 'C'; 'E'; 'E'; 'C']

Press any key to continue . . .

*)