結城 浩さんからのアルゴリズムの問題 https://codeiq.jp/ace/yuki_hiroshi/q684 (F# versionとOCaml version)

gemstring.fs

//5578864439
//ENV: F#
//POINT: 未使用の文字から何種類できるかについてメモ化再帰で全探索。メモのポイントは種類を無視して個数の組み合わせをキーにする。また、答えは32bitで桁あふれするので注意。
//感想: 久しぶりの出題で楽しかったです。最初全部メモしてどうにも遅かったので回答をあきらめそうになりましたが純粋な再帰関数を作って呼ばれるパラメーターのダンプをみていたらメモする方法を思いつきました。ただの数え上げでは２時間くらいかかったけど、メモ化したら１秒以下になりました。

let solve gems target =
    let gems = List.ofSeq gems in
    let target = List.ofSeq target in
    let target_rev = target |> List.rev in
    let memo = ref Map.empty in
    let usememo busy =
        let rec loop rhs lhs =
            match rhs, lhs with
            | r :: rx, l :: lx when r = l -> loop rx lx
            | [], _ -> false
            | _ -> true
        in
        loop (List.rev busy) target
    let key idle =
        idle
        |> Seq.groupBy id
        |> Seq.map (Seq.length << snd)
        |> Seq.sort
        |> List.ofSeq
    in
    let rec count num busy idle =
        printfn "%d:%s:%A:%A" num (busy |> List.rev |> Array.ofList |> fun x -> new System.String(x)) (key idle) (usememo busy)
        if busy = target_rev then
            num, Some num
        else
        let tmp = if usememo busy then Map.tryFind (key idle) !memo else None in
        match tmp with
        | Some n -> n
        | _ ->
        let idle = List.sort idle in
        let rec loop acc back = function
            | x :: xs ->
                let n, found = 
                    if List.exists ((=) x) back then 0L, None
                    else count (num+acc+1L) (x::busy) (back@xs)
                in
                match found with
                | None -> loop (acc+n) (x::back) xs
                | _ -> n, found
            | [] -> acc + 1L, None
        in
        let ans = loop 0L [] idle in
        memo := Map.add (key idle) ans !memo;
        ans
    in
    count 0L [] gems |> function
    | _, Some n -> n
    | _ -> 0L

[<EntryPoint>]
let main argv = 
//    printfn "%d" <| solve "aaabcc" "bca"
    printfn "answer=%d" <| solve "abbbbcddddeefggg" "eagcdfbe"
    0 // 整数の終了コードを返します

gemstring.ml

(*
5578864439
ENV: OCaml
POINT: 未使用の文字から何種類できるかについてメモ化再帰で全探索。メモのポイントは種類を無視して個数の組み合わせをキーにする。また、答えは32bitで桁あふれするので注意。
感想: 久しぶりの出題で楽しかったです。最初全部メモしてどうにも遅かったので回答をあきらめそうになりましたが純粋な再帰関数を作って呼ばれるパラメーターのダンプをみていたらメモする方法を思いつきました。ただの数え上げでは２時間くらいかかったけど、メモ化したら１秒以下になりました。
*)
 
let id x = x
let (|>) x f = f x
let (@@) f x = f x
let ($) f g x = f (g x)
let (++) = Int64.add

let printfn fmt = Printf.ksprintf print_endline fmt
let string_of_intlist = String.concat " " $ List.map string_of_int

let explode s =
  let rec exp i l =
    if i < 0 then l else exp (i - 1) (s.[i] :: l) in
  exp (String.length s - 1) []

let implode l =
  let res = String.create (List.length l) in
  let rec imp i = function
    | [] -> res
    | c :: l -> res.[i] <- c; imp (i + 1) l in
  imp 0 l

let try_find m x =
  try Some (Hashtbl.find m x) with
  | _ -> None

let group_by keyf xs =
  let m = Hashtbl.create 13 in
  List.iter (fun x ->
      let k = keyf x in
      match try_find m k with
      | Some v -> Hashtbl.replace m k (x::v)
      | None -> Hashtbl.add m k [x]
    ) xs;
  Hashtbl.fold (fun k v s -> (k, List.rev v) :: s) m [] 

let solve gems target =
  let gems = explode gems in
  let target = explode target in
  let target_rev = target |> List.rev in
  let memo = Hashtbl.create 13 in
  let usememo busy =
    let rec loop lhs rhs =
      match lhs, rhs with
      | l :: ls, r :: rs  when r = l -> loop ls rs 
      | [], _ -> false
      | _ -> true
    in
    loop (List.rev busy) target
  in
  let key idle =
    idle
    |> group_by id
    |> List.map (List.length $ snd)
    |> List.sort compare
  in
  let rec count num busy idle =
    printfn "%Ld:%s:(%s):%b" num (busy |> List.rev |> implode)
      (string_of_intlist @@ key idle) (usememo busy);
    if busy = target_rev then
      num, Some num
    else
      match if usememo busy then try_find memo (key idle) else None with
      | Some ans -> ans
      | _ ->
        let idle = List.sort compare idle in
        let rec loop acc back = function
          | x :: xs ->
            let n, found = 
              if List.exists ((=) x) back then 0L, None
              else count (num ++ acc ++ 1L) (x::busy) (back@xs)
            in
            (match found with
             | None -> loop (acc ++ n) (x::back) xs
             | _ -> n, found)
          | [] -> acc ++ 1L, None
        in
        let ans = loop 0L [] idle in
        Hashtbl.add memo (key idle) ans;
        ans
  in
  count 0L [] gems |> function
  | _, Some n -> n
  | _ -> 0L

let () =
(*
  let gems = "aaabcc" in
  let target = "bca" in
 *)
  let gems = "abbbbcddddeefggg" in
  let target = "eagcdfbe" in
  printfn "answer=%Ld" @@ solve gems target