Brickdragning

structure Draws : DRAWS =
struct

open Generic
infix 5 =*
infix 5 =~

datatype tile = C of char | Blank

val tilebag =
    [(8,C #"a"),

     (2,C #"b"),
     (1,C #"c"),
     (5,C #"d"),
     (7,C #"e"),
     (2,C #"f"),
     (3,C #"g"),
     (2,C #"h"),
     (5,C #"i"),
     (1,C #"j"),
     (3,C #"k"),
     (5,C #"l"),
     (3,C #"m"),
     (6,C #"n"),
     (5,C #"o"),
     (2,C #"p"),
     (8,C #"r"),
     (8,C #"s"),
     (8,C #"t"),
     (3,C #"u"),
     (2,C #"v"),
     (1,C #"x"),
     (1,C #"y"),
     (1,C #"z"),
     (2,C #"å"),
     (2,C #"ä"),
     (2,C #"ö"),
     (2,Blank)]

fun tiles l =
    List.foldr (fn ((n,_),m) => n+m) 0 l

fun draw_nth n [] b = raise Domain
  | draw_nth n ((m,t)::r) b =
    if n <= m then
    if m = 1 then
        (t,b@r)
    else
        (t,(m-1,t)::r@b)
    else
    draw_nth (n-m) r ((m,t)::b)

fun draw_random g _ 0 = (g,[])
  | draw_random g b n =
    let
    val (t,b) = draw_nth (Rand.range (1,tiles b) g) b []
    val (g',r) = draw_random (Rand.random g) b (n-1)
    in
    (g',t::r)
    end

fun has c b =
    List.exists (fn (n,b) => c = b andalso n>0) b

fun numberOf c b =
    case List.find (fn (_,b) => c = b) b of
    NONE => 0
      | SOME(n,_) => n

fun insertBlanks ban (f::r) =
    let
    fun insertBlanks' ban (f::r) =
        if f =* ban then
        map (fn l => C f::l) (insertBlanks' (f::ban) r)
        else
        map (fn l => C f::l) (insertBlanks' (f::ban) r)
        @
        [Blank::map C r]
      | insertBlanks' _ [] = [[]]
    in
    if f =* ban then
        map (fn l => C f::l) (insertBlanks (f::ban) r)
    else
        map (fn l => C f::l) (insertBlanks (f::ban) r)
        @
        map (fn l => Blank::l) (insertBlanks' ban r)
    end
  | insertBlanks _ [] = [[]]

fun tileCompare (C a, C b) = Char.compare(a,b)
  | tileCompare (Blank, C _) = LESS
  | tileCompare (C _, Blank) = GREATER
  | tileCompare _ = EQUAL

val uniques = ListMergeSort.uniqueSort tileCompare

fun copies_of l e =
    length(List.filter (fn e' => e' = e) l)

fun factorial 0 = 1
  | factorial n = n * factorial(n-1)

fun draws' t w =
    let
    fun picks e =
        let
        val a = numberOf e t
        val b = copies_of w e
        in
        if b > a then
            0
        else
            let
            val n = factorial a
            val m = factorial b
            val m' = factorial(a - b)
            in
            n div (m*m')
            end
        end

    val u = uniques w
    val l = map picks u
    in
    List.foldr (op * ) 1 l
    end


fun draws w =
    let
    val b = insertBlanks [] (explode w)
    val c = map (fn b => draws' tilebag b) b
    in
    List.foldr (op +) 0 c
    end

fun drawable' t w =
    let
    fun picks e =
        let
        val a = numberOf e t
        val b = copies_of w e
        in
        if b > a then
            0
        else
            1
        end

    val u = uniques w
    val l = map picks u
    in
    List.foldr (op * ) 1 l
    end


fun drawable w =
    case
    let
        val b = insertBlanks [] (explode w)
        val c = map (fn b => drawable' tilebag b) b
    in
        List.foldr (op +) 0 c
    end
     of
    0 => false
      | _ => true

fun drawable_from cl w =
    let
    fun tile_of #"?" = Blank
      | tile_of c = C c
    val cl' = map tile_of cl
    val cl'' = uniques cl'
    val bag = map (fn t => (copies_of cl' t,t)) cl''
    in
    case
    let
        val b = insertBlanks [] (explode w)
        val c = map (fn b => drawable' bag b) b
    in
        List.foldr (op +) 0 c
    end
     of
    0 => false
      | _ => true
    end

end