{-
Copyright 2008 by Ken Takusagawa

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see http://www.gnu.org/licenses/.
-}
module Main (main) where{
import IO;
import System.IO.Unsafe;
import Control.Monad.ST;
import Control.Monad.Error;
import Control.Monad.State;
import qualified Data.Set as Set;
import Data.Array.ST;
import Maybe;
import Random;
import Char;
import System;
import Data.STRef;
import Data.Array.IArray;
import Data.Ord;
import Control.Parallel.Strategies;
import Data.List;

<strong>main</strong> :: IO(());
main = (do{
  (getArgs >>= (\lambda_case_var ->case lambda_case_var of {
  ["nothing"]-> (return ());
  ["template"]-> template;
  ["do-move"]-> do_move;
  ["go", (x)]-> (go (read x));
  ["gob", (x)]-> (no_blank (read x));
  ["show-test"]-> (putStr (show_board test_board show_mchar))
}));
});
<strong>show_list</strong> :: (Show (a)) => [](a) -> String;
show_list l = (unlines (map show l));
<strong>zip_map</strong> :: (a -> b) -> [](a) -> []((a, b));
zip_map f l = (zip l (map f l));
<strong>zip_map_parallel</strong> :: Strategy(b) -> (a -> b) -> [](a) -> []((a, b));
zip_map_parallel strat f l = (zip l (using (map f l) (parList strat)));
<strong>map_tuple</strong> :: (a -> b) -> (a, a) -> (b, b);
map_tuple fn x = ((fn (fst x)), (fn (snd x)));
<strong>reverse_comparison</strong> :: Ordering -> Ordering;
reverse_comparison o = (case o of {
  (LT)-> GT;
  (EQ)-> EQ;
  (GT)-> LT
});
<strong>reverse_comparison_function</strong> :: (a -> a -> Ordering) -> (a -> a -> Ordering);
reverse_comparison_function f = (curry((reverse_comparison . (uncurry f))));
<strong>zip_check_same_length</strong> :: [](a) -> [](b) -> []((a, b));
zip_check_same_length x1 x2 = (case (x1, x2) of {
  (([]), ([]))-> [];
  (((:)(a) (arest)), ((:)(b) (brest)))-> ((:) (a, b) (zip_check_same_length arest brest))
});
<strong>zipWith_check_same_length</strong> :: (a -> b -> c) -> [](a) -> [](b) -> [](c);
zipWith_check_same_length f x1 x2 = (case (x1, x2) of {
  (([]), ([]))-> [];
  (((:)(a) (arest)), ((:)(b) (brest)))-> ((:) (f a b) (zipWith_check_same_length f arest brest))
});
<strong>apply_first</strong> :: (a -> b) -> (a, c) -> (b, c);
apply_first fn x = ((fn (fst x)), (snd x));
<strong>apply_second</strong> :: (a -> b) -> (c, a) -> (c, b);
apply_second fn x = ((fst x), (fn (snd x)));
<strong>uniform_random_IO</strong> :: IO(Float);
uniform_random_IO = (randomRIO (0, 1));
<strong>random_permutation_IO</strong> :: [](a) -> IO([](a));
random_permutation_IO l = ((sequence (replicate (length l) uniform_random_IO)) >>= (return . (map fst) . (sortBy (comparing snd)) . (zip_check_same_length l)));
<strong>filter_justs</strong> :: ([](Maybe(a)) -> [](a));
filter_justs = ((map fromJust) . (filter isJust));
<strong>rcs_code</strong> :: String;
rcs_code = "$Id$";
<strong>newtype RRow </strong> = RRow(Int) deriving (Ix, Ord, Eq, Enum, Show);
<strong>newtype CCol </strong> = CCol(Int) deriving (Num, Show, Eq, Ix, Ord, Enum, NFData);
<strong>type Coord </strong> = (RRow, CCol);
<strong>type RC_board a</strong> = Array(RRow)(Array(CCol)(a));
<strong>type Board </strong> = VV_board(Char);
<strong>type VV_board a</strong> = RC_board(Maybe(a));
<strong>type Before_and_after </strong> = (String, String);
<strong>type MString </strong> = [](Mchar);
<strong>mmatch</strong> :: (Eq (char)) => char -> Maybe(char) -> Maybe(Maybe(char));
mmatch c r = (case r of {
  (Just(rx))-> (case ((==) c rx) of {
  (True)-> (Just (Nothing ));
  (_)-> Nothing
});
  (Nothing)-> (Just (Just (c )))
});
<strong>mfits_half_row</strong> :: String -> MString -> Maybe([](Maybe(Char)));
mfits_half_row word row = (mapM (uncurry mmatch) (zip_check_same_length word row));
<strong>type Row </strong> = Array(CCol)(Mchar);
<strong>type Mchar </strong> = Maybe(Char);
<strong>mmatch_row</strong> :: Before_and_after -> Row -> CCol -> Maybe(Put_letters);
mmatch_row word row position = (let {
p_left = ((-) position (CCol (length (fst word))));
p_right = ((+) position (CCol (length (snd word))))
}
 in (do{
  (guard ((&lt;=) (fst (bounds row)) p_left));
  (guard ((||) ((==) p_left (fst (bounds row))) (isNothing ((!) row (pred p_left)))));
  left :: [](Mchar) &lt;- (mfits_half_row (fst word) (array_subrange row p_left (pred position)));
  (guard ((&lt;=) p_right (snd (bounds row))));
  (guard ((||) ((==) p_right (snd (bounds row))) (isNothing ((!) row (succ p_right)))));
  right :: [](Mchar) &lt;- (mfits_half_row (snd word) (array_subrange row (succ position) p_right));
  (guard ((||) (not (null (filter isJust left))) (not (null (filter isJust right)))));
  (return ((p_left, p_right), (get_justs((zip_check_same_length (enumFromTo p_left p_right))((left ++ [Nothing] ++ right))))));
}));
<strong>array_subrange</strong> :: (Enum (i), Ix (i)) => Array(i)(a) -> i -> i -> [](a);
array_subrange v start end = ((map ((!) v))((enumFromTo start end)));
<strong>read_mchar</strong> :: Char -> Mchar;
read_mchar c = (case c of {
  ('.')-> Nothing;
  (x)-> (Just x)
});
<strong>mkrow</strong> :: (a -> b) -> [](a) -> Array(CCol)(b);
mkrow f s = (listArray ((CCol 1), (CCol (length s))) (map f s));
<strong>mkboard</strong> :: (a -> b) -> []([](a)) -> RC_board(b);
mkboard f ss = (listArray ((RRow 1), (RRow (length ss))) (map (mkrow f) ss));
<strong>test_board</strong> :: Board;
test_board = (fst (make_test_board "....drip"));
<strong>make_test_board</strong> :: String -> Board_state;
make_test_board first_move = (let {
<strong>test_board</strong> :: Board;
test_board = (transpose_board((mkboard read_mchar)(((replicate 7 "...............") ++ [(take 15 ((++) first_move (repeat '.')))] ++ (replicate 7 "...............")))))
}
 in (make_board_state test_board (blankless_board_points test_board)));
<strong>check_a_orthogonal</strong> :: (Enum (ix), Ord (ix)) => Is_word -> (ix -> Mchar) -> (ix, ix) -> ix -> Char -> Maybe(Maybe((ix, ix)));
check_a_orthogonal is_word column bounds_column i c = (let {
up = (follow_pred column (fst bounds_column) i);
down = (follow_succ column (snd bounds_column) i)
}
 in (case ((==) up down) of {
  (True)-> (Just Nothing);
  (_)-> (do{
  (guard(is_word((((map (fromJust . column))((enumFromTo up (pred i)))) ++ [c] ++ ((map (fromJust . column))((enumFromTo (succ i) down)))))));
  (return (Just (up, down)));
})
}));
<strong>follow_pred</strong> :: (Enum (ix), Ord (ix)) => (ix -> Maybe(a)) -> ix -> ix -> ix;
follow_pred row min p = (case (compare min p) of {
  (EQ)-> p;
  (LT)-> (case (row (pred p)) of {
  (Nothing)-> p;
  (_)-> (follow_pred row min (pred p))
})
});
<strong>follow_succ</strong> :: (Enum (ix), Ord (ix)) => (ix -> Maybe(a)) -> ix -> ix -> ix;
follow_succ row max p = (case (compare p max) of {
  (EQ)-> p;
  (LT)-> (case (row (succ p)) of {
  (Nothing)-> p;
  (_)-> (follow_succ row max (succ p))
})
});
<strong>type Put_letters </strong> = ((CCol, CCol), Put_letters_list);
<strong>type Put_letters_list </strong> = []((CCol, Char));
<strong>type Horizontal_result </strong> = (RRow, Put_letters);
<strong>type Resulting_words </strong> = (Horizontal_result, [](Vertical));
<strong>type Vertical </strong> = (CCol, (RRow, RRow));
<strong>type Play </strong> = (Resulting_words, Tiles_you_have);
<strong>board_check_word</strong> :: Is_word -> Board -> RRow -> CCol -> Before_and_after -> Maybe(Resulting_words);
board_check_word is_word horizontals row col word = (do{
  put_letters :: Put_letters &lt;- (mmatch_row word ((!) horizontals row) col);
  created_vertical_words :: []((CCol, Maybe((RRow, RRow)))) &lt;- (mapM (uncurry (check_vertical is_word horizontals row)) (snd put_letters));
  (return ((row, put_letters), (get_justs created_vertical_words)));
});
<strong>get_justs</strong> :: []((a, Maybe(b))) -> []((a, b));
get_justs created_vertical_words = ((map (apply_second fromJust))((filter (isJust . snd))(created_vertical_words)));
<strong>check_vertical</strong> :: Is_word -> Board -> RRow -> CCol -> Char -> Maybe((CCol, Maybe((RRow, RRow))));
check_vertical is_word horizontals row column c = (do{
  updown :: Maybe((RRow, RRow)) &lt;- (check_a_orthogonal is_word (transpose_vv horizontals column) (bounds horizontals) row c);
  (return (column, updown));
});
<strong>transpose_vv</strong> :: (Ix (r), Ix (c)) => Array(r)(Array(c)(a)) -> c -> r -> a;
transpose_vv vv y x = ((!) ((!) vv x) y);
<strong>transpose_board</strong> :: forall a . RC_board(a) -> RC_board(a);
transpose_board b = (let {
<strong>left_right</strong> :: (CCol, CCol);
left_right = (bounds(((!) b)(fst(bounds(b)))));
<strong>to_rrow</strong> :: CCol -> RRow;
to_rrow c = (case c of {
  (CCol(x))-> (RRow x)
});
<strong>to_ccol</strong> :: RRow -> CCol;
to_ccol r = (case r of {
  (RRow(x))-> (CCol x)
});
<strong>create_column</strong> :: CCol -> Array(CCol)(a);
create_column col = (let {
<strong>get</strong> :: Array(CCol)(a) -> a;
get r = ((!) r col)
}
 in ((listArray((map_tuple to_ccol)(bounds(b))))((map get)(elems(b)))))
}
 in ((listArray (map_tuple to_rrow left_right))((map create_column)(range(left_right)))));
<strong>go_test_board</strong> :: Before_and_after -> Int -> Int -> Maybe(Resulting_words);
go_test_board word row col = (board_check_word (const True) test_board (RRow row) (CCol col) word);
<strong>type Underflow </strong> = ();
instance Error (Underflow) where {
noMsg = ()
}
;
<strong>process_letter</strong> :: STRef(s)(Int) -> STArray(s)(Char)(Int) -> Char -> ErrorT(Underflow)(ST(s))(());
process_letter pnum_blanks letters c = ((lift(runErrorT((countdown_array letters)(c)))) >>= (\lambda_case_var ->case lambda_case_var of {
  (Right(_))-> (return ());
  (Left(_))-> ((lift (readSTRef pnum_blanks)) >>= (\lambda_case_var ->case lambda_case_var of {
  (0)-> (throwError ());
  (num_blanks)-> (lift((writeSTRef pnum_blanks)(pred(num_blanks))))
}))
}));
<strong>type Tiles_you_have </strong> = (Int, Array(Char)(Int));
<strong>process_word</strong> :: Tiles_you_have -> String -> Maybe(Tiles_you_have);
process_word current_tiles w = (case (runST(runErrorT((do{
  pnum_blanks :: STRef(s)(Int) &lt;- (lift (newSTRef (fst current_tiles)));
  pletters :: STArray(s)(Char)(Int) &lt;- (lift (thaw (snd current_tiles)));
  (mapM_ (process_letter pnum_blanks pletters) w);
  blanks_left :: Int &lt;- (lift (readSTRef pnum_blanks));
  letters_left :: Array(Char)(Int) &lt;- (lift (freeze pletters));
  (return (blanks_left, letters_left));
})))) of {
  (Left(_))-> Nothing;
  (Right(x))-> (Just x)
});
<strong>mkarray</strong> :: String -> Array(Char)(Int);
mkarray s = (let {
<strong>accum_func</strong> :: Int -> Int -> Int;
accum_func old _ = (succ old)
}
 in (accumArray accum_func 0 alphabet (zip s (repeat undefined))));
<strong>type Is_word </strong> = (String -> Bool);
<strong>parallel_word_check_vertical</strong> :: Is_word -> Board -> RRow -> Put_letters_list -> Maybe([](Vertical));
parallel_word_check_vertical is_word horizontals row put_letters = ((mapM (uncurry (check_vertical is_word horizontals row)) put_letters) >>= (return . get_justs));
<strong>is_open_area</strong> :: CCol -> VV_board(a) -> RRow -> CCol -> Bool;
is_open_area width b i j = (isJust (do{
  (guard ((&lt;=) (pred ((+) j width)) (snd(bounds(((!) b)(i))))));
  (mapM_ (guard . (empty_at b i)) (enumFromTo (pred j) ((+) j width)));
  (let {
<strong>word_range</strong> :: [](CCol);
word_range = (enumFromTo j (pred ((+) j width)))
}
 in (guard (not ((&amp;&amp;) (and (map (empty_at b (pred i)) word_range)) (and (map (empty_at b (succ i)) word_range))))));
  (return ());
}));
<strong>empty_at</strong> :: VV_board(a) -> RRow -> CCol -> Bool;
empty_at b i j = (not ((&amp;&amp;) (inRange (bounds b) i) ((&amp;&amp;) (inRange (bounds ((!) b i)) j) (isJust ((!) ((!) b i) j)))));
<strong>all_board_coordinates</strong> :: VV_board(a) -> [](Coord);
all_board_coordinates b = (do{
  r :: RRow &lt;- (range (bounds b));
  c :: CCol &lt;- (range(bounds(((!) b)(fst(bounds(b))))));
  (return (r, c));
});
<strong>find_open_areas</strong> :: VV_board(a) -> CCol -> [](Coord);
find_open_areas b width = (filter (uncurry (is_open_area width b)) (all_board_coordinates b));
<strong>type Open_areas </strong> = Array(CCol)([](Coord));
<strong>max_tiles</strong> :: Int;
max_tiles = 7;
<strong>find_all_open_areas</strong> :: VV_board(a) -> Open_areas;
find_all_open_areas b = (listArray ((CCol 1), (CCol max_tiles)) (map ((find_open_areas b) . CCol) (enumFromTo 1 max_tiles)));
<strong>spellable_t</strong> :: Is_word -> Board -> RRow -> CCol -> Tiles_you_have -> Before_and_after -> Maybe(Play);
spellable_t is_word b row col current_tiles word = (do{
  resulting :: Resulting_words &lt;- (board_check_word is_word b row col word);
  next_tiles :: Tiles_you_have &lt;- (process_word current_tiles ((map snd)(snd(snd(fst(resulting))))));
  (return (resulting, next_tiles));
});
<strong>do_t</strong> :: [](Before_and_after) -> Is_word -> Board -> Tiles_you_have -> RRow -> CCol -> [](Play);
do_t words is_word b current_tiles row col = (sort(filter_justs((map (spellable_t is_word b row col current_tiles))(words))));
<strong>left_is_clear_point</strong> :: VV_board(a) -> RRow -> CCol -> Bool;
left_is_clear_point b row col = ((&amp;&amp;) (not (empty_at b row col)) (empty_at b row (pred col)));
<strong>show_board</strong> :: RC_board(a) -> (a -> String) -> String;
show_board b f = (unlines((map (show_board_row f))(elems(b))));
<strong>show_board_row</strong> :: (a -> String) -> Array(CCol)(a) -> String;
show_board_row f row = ((concatMap f)(elems(row)));
<strong>show_mchar</strong> :: Mchar -> String;
show_mchar m = (case m of {
  (Nothing)-> ".";
  (Just(c))-> [c]
});
<strong>map_ix_array</strong> :: (Ix (ix)) => (ix -> a -> b) -> Array(ix)(a) -> Array(ix)(b);
map_ix_array f v = (listArray (bounds v) (map (uncurry f) (assocs v)));
<strong>map_rc</strong> :: (RRow -> CCol -> a -> b) -> RC_board(a) -> RC_board(b);
map_rc f vv = (map_ix_array (map_rc_row f) vv);
<strong>map_rc_row</strong> :: (RRow -> CCol -> a -> b) -> RRow -> Array(CCol)(a) -> Array(CCol)(b);
map_rc_row f r v = (map_ix_array (f r) v);
<strong>go_do_t</strong> :: B_a_list -> Is_word -> Board -> Tiles_you_have -> RRow -> CCol -> [](Play);
go_do_t b_a_list is_word b current_tiles row col = (do_t (build_before_and_after ((!) b_a_list (fromJust ((!) ((!) b row) col)))) is_word b current_tiles row col);
<strong>type B_a_list </strong> = Array(Char)(B_a_internal);
<strong>type B_a_internal </strong> = [](Before_and_after);
<strong>build_before_and_after</strong> :: B_a_internal -> [](Before_and_after);
build_before_and_after int = int;
<strong>words_io</strong> :: IO([](String));
words_io = ((>>=) (readFile "dictionary") (return . lines));
<strong>all_words</strong> :: [](String);
all_words = (unsafePerformIO words_io);
<strong>all_words_set</strong> :: Set.Set(String);
all_words_set = (Set.fromList all_words);
<strong>all_is_word</strong> :: String -> Bool;
all_is_word w = (Set.member w all_words_set);
<strong>split_at_char</strong> :: Char -> String -> String -> [](Before_and_after);
split_at_char c pre l = (case l of {
  ([])-> [];
  ((:)(h) (t))-> (let {
<strong>do_rest</strong> :: [](Before_and_after);
do_rest = (split_at_char c ((:) h pre) t)
}
 in (case ((==) h c) of {
  (True)-> ((:) ((reverse pre), t) do_rest);
  (_)-> do_rest
}))
});
<strong>alphabet</strong> :: (Char, Char);
alphabet = ('a', 'z');
<strong>get_all_splits</strong> :: [](String) -> Char -> [](Before_and_after);
get_all_splits words c = (words >>= (split_at_char c "") >>= return);
<strong>get_ba_list</strong> :: [](String) -> B_a_list;
get_ba_list words = (listArray alphabet (map (get_all_splits words) (range alphabet)));
<strong>all_ba_list</strong> :: B_a_list;
all_ba_list = (get_ba_list all_words);
<strong>place_parallel_word</strong> :: Tiles_you_have -> Open_areas -> Is_word -> Board -> [](String) -> [](Play);
place_parallel_word current_tiles open_spaces is_word b all_words = (do{
  word :: String &lt;- all_words;
  tiles_left :: Tiles_you_have &lt;- (maybeToList (process_word current_tiles word));
  where_to_put :: Coord &lt;- ((!) open_spaces (CCol (length word)));
  (let {
<strong>put_letters</strong> :: Put_letters;
put_letters = (((snd where_to_put), (pred ((+) (snd where_to_put) (CCol (length word))))), (zip (enumFrom (snd where_to_put)) word))
}
 in (do{
  verticals :: [](Vertical) &lt;- (maybeToList (parallel_word_check_vertical is_word b (fst where_to_put) (snd put_letters)));
  (return ((((fst where_to_put), put_letters), verticals), tiles_left));
}));
});
<strong>scan_orthogonal_plays</strong> :: Board -> Tiles_you_have -> [](Play);
scan_orthogonal_plays b current_tiles = (do{
  rc :: Coord &lt;- (all_board_coordinates b);
  (guard (uncurry (left_is_clear_point b) rc));
  ((uncurry (go_do_t all_ba_list all_is_word b current_tiles) rc) >>= return);
});
<strong>scan_parallel_plays</strong> :: Board -> Tiles_you_have -> [](Play);
scan_parallel_plays b current_tiles = (place_parallel_word current_tiles (find_all_open_areas b) all_is_word b all_words);
<strong>scan_plays_one_board</strong> :: Board -> Tiles_you_have -> [](Play);
scan_plays_one_board b current_tiles = ((++) (scan_orthogonal_plays b current_tiles) (scan_parallel_plays b current_tiles));
<strong>newtype Points </strong> = Points(Int) deriving (Num, Show, Eq, NFData);
instance Ord (Points) where {
compare x y = (case (x, y) of {
  ((Points(x1)), (Points(y1)))-> (case (compare x1 y1) of {
  (LT)-> GT;
  (EQ)-> EQ;
  (GT)-> LT
})
})
}
;
<strong>score_letter</strong> :: STArray(s)(Char)(Int) -> Char -> ST(s)(Points);
score_letter letters c = ((runErrorT (do{
  (countdown_array letters c);
  (return (get_points c));
})) >>= (\lambda_case_var ->case lambda_case_var of {
  (Left(_))-> (return points_blank);
  (Right(s))-> (return s)
}));
<strong>countdown_array</strong> :: (Ix (char), Enum (int), Num (int)) => STArray(s)(char)(int) -> char -> ErrorT(Underflow)(ST(s))(());
countdown_array letters c = ((lift (readArray letters c)) >>= (\lambda_case_var ->case lambda_case_var of {
  (0)-> (throwError ());
  (num_that_letter)-> (lift((writeArray letters c)(pred(num_that_letter))))
}));
<strong>points_blank</strong> :: Points;
points_blank = (Points 0);
<strong>get_points</strong> :: Char -> Points;
get_points c = ((!) point_values_array c);
<strong>point_values_array</strong> :: Array(Char)(Points);
point_values_array = (let {
<strong>simple_point_values</strong> :: []((Int, String));
simple_point_values = [(2, "dg"), (3, "bcmp"), (4, "fhvwy"), (5, "k"), (8, "jx"), (10, "qz")];
<strong>expand_simple_point_values</strong> :: (Int, String) -> []((Char, Points));
expand_simple_point_values f = (do{
  c :: Char &lt;- (snd f);
  (return (c, (Points (fst f))));
})
}
 in (accumArray (flip const) (Points 1) alphabet (concatMap expand_simple_point_values simple_point_values)));
<strong>newtype Letter_multiplier </strong> = Letter_multiplier(Int) deriving (Ord, Eq);
<strong>board_letter_multiplier</strong> :: RC_board(Letter_multiplier);
board_letter_multiplier = (let {
<strong>char_mult</strong> :: Char -> Letter_multiplier;
char_mult c = (Letter_multiplier (case c of {
  ('c')-> 2;
  ('b')-> 3;
  (_)-> 1
}))
}
 in (mkboard char_mult master_board));
<strong>board_word_multiplier</strong> :: RC_board(Word_multiplier);
board_word_multiplier = (let {
<strong>word_mult</strong> :: Char -> Word_multiplier;
word_mult c = (Word_multiplier (case c of {
  ('r')-> 3;
  ('p')-> 2;
  (_)-> 1
}))
}
 in (mkboard word_mult master_board));
<strong>board_width</strong> :: (CCol, CCol);
board_width = ((CCol 1), (CCol(length(head(master_board)))));
<strong>master_board</strong> :: [](String);
master_board = (flip_double((map flip_double)(["r..c...r", ".p...b..", "..p...c.", "c..p...c", "....p...", ".b...b..", "..c...c.", "r..c...p"])));
<strong>flip_double</strong> :: [](a) -> [](a);
flip_double l = ((++) l (reverse(init(l))));
<strong>expand_row_cols</strong> :: RRow -> [](CCol) -> [](Coord);
expand_row_cols r cs = (let {
<strong>make</strong> :: CCol -> Coord;
make c = (r, c)
}
 in (map make cs));
<strong>expand_col_rows</strong> :: CCol -> [](RRow) -> [](Coord);
expand_col_rows c cs = (let {
<strong>make</strong> :: RRow -> Coord;
make r = (r, c)
}
 in (map make cs));
<strong>type Coord_char </strong> = (Coord, Char);
<strong>lookup_rc</strong> :: RC_board(a) -> Coord -> a;
lookup_rc b xy = ((!) ((!) b (fst xy)) (snd xy));
<strong>score_word</strong> :: Tiles_you_have -> String -> [](Points);
score_word current_tiles w = (let {
<strong>in_st</strong> :: forall s . ST(s)([](Points));
in_st = (do{
  pletters :: STArray(s)(Char)(Int) &lt;- (thaw (snd current_tiles));
  ret :: [](Points) &lt;- (mapM (score_letter pletters) w);
  (return ret);
})
}
 in (runST in_st));
<strong>reformat_horizontal_result</strong> :: Horizontal_result -> [](Coord_char);
reformat_horizontal_result r = (zip_check_same_length ((expand_row_cols (fst r))((map fst)(snd(snd(r))))) ((map snd)(snd(snd(r)))));
<strong>type Point_col </strong> = Array(CCol)(Points);
<strong>point_array_row</strong> :: Tiles_you_have -> Horizontal_result -> Point_col;
point_array_row current_tiles r = (let {
<strong>sorted</strong> :: [](Coord_char);
sorted = ((map fst)((sortBy (reverse_comparison_function (comparing snd)))((zip_map ((lookup_rc board_letter_multiplier) . fst))(reformat_horizontal_result(r)))))
}
 in ((accumArray (flip const) bad_points board_width)((map (apply_first snd))((zip_check_same_length ((map fst)(sorted)) ((score_word current_tiles)((map snd)(sorted))))))));
<strong>bad_points</strong> :: Points;
bad_points = (head [(error "bad-points: should never look at this"), (Points (negate 999))]);
<strong>newtype Word_multiplier </strong> = Word_multiplier(Int);
<strong>type Board_points </strong> = VV_board(Points);
<strong>get_board_points</strong> :: Board_points -> [](Coord) -> Points;
get_board_points board_points l = (sum(filter_justs((map (lookup_rc board_points))(l))));
<strong>score_play_horiz</strong> :: Board_points -> Point_col -> Horizontal_result -> Points;
score_play_horiz board_points point_col h = (let {
<strong>reformatted</strong> :: [](Coord);
reformatted = ((map fst)(reformat_horizontal_result(h)));
<strong>already_board_points</strong> :: Points;
already_board_points = ((get_board_points board_points)((expand_row_cols (fst(h)) (range (fst(snd(h)))))));
<strong>word_mult</strong> :: [](Word_multiplier);
word_mult = ((map (lookup_rc board_word_multiplier))(reformatted));
<strong>letter_mult</strong> :: [](Letter_multiplier);
letter_mult = ((map (lookup_rc board_letter_multiplier))(reformatted));
<strong>cols</strong> :: [](Points);
cols = ((map ((!) point_col))((map snd)(reformatted)))
}
 in (foldl mult_word (((+) already_board_points)(sum((zipWith_check_same_length mult_letter cols letter_mult)))) word_mult));
<strong>mult_letter</strong> :: Points -> Letter_multiplier -> Points;
mult_letter p m = (case m of {
  (Letter_multiplier(l))-> ((*) p (Points l))
});
<strong>mult_word</strong> :: Points -> Word_multiplier -> Points;
mult_word p m = (case m of {
  (Word_multiplier(l))-> ((*) p (Points l))
});
<strong>score_play_vertical</strong> :: Board_points -> (RRow, RRow) -> RRow -> CCol -> Points -> Points;
score_play_vertical board_points rows row col point_at = (let {
<strong>already_board_points</strong> :: Points;
already_board_points = ((get_board_points board_points)((expand_col_rows col (range rows))));
<strong>coord</strong> :: Coord;
coord = (row, col)
}
 in (mult_word ((+) already_board_points (mult_letter point_at (lookup_rc board_letter_multiplier coord))) (lookup_rc board_word_multiplier coord)));
<strong>go_score_play_vertical</strong> :: Board_points -> Point_col -> RRow -> Vertical -> Points;
go_score_play_vertical board_points point_col row v = (score_play_vertical board_points (snd v) row (fst v) ((!) point_col (fst v)));
<strong>score_all_verticals</strong> :: Board_points -> Point_col -> Resulting_words -> Points;
score_all_verticals board_points point_col result = (sum((map (go_score_play_vertical board_points point_col (fst(fst(result)))))(snd(result))));
<strong>score_result</strong> :: Tiles_you_have -> Board_points -> Resulting_words -> (Points, Point_col);
score_result current_tiles board_points result = (let {
<strong>point_col</strong> :: Point_col;
point_col = (point_array_row current_tiles (fst result));
<strong>bingo_bonus_points</strong> :: Points;
bingo_bonus_points = (Points (case ((==) max_tiles (length(snd(snd(fst(result)))))) of {
  (True)-> 50;
  (_)-> 0
}))
}
 in (((+) bingo_bonus_points ((+) ((score_play_horiz board_points point_col)(fst(result))) ((score_all_verticals board_points point_col)(result)))), point_col));
<strong>blankless_board_points</strong> :: Board -> Board_points;
blankless_board_points b = (map_rc get_blankless_board_points b);
<strong>get_blankless_board_points</strong> :: RRow -> CCol -> Mchar -> Maybe(Points);
get_blankless_board_points _ _ x = (x >>= (return . get_points));
<strong>update_board_2</strong> :: RRow -> Put_letters_list -> Board -> Board;
update_board_2 row pl b = ((//) b [(row, (update_board_row ((!) b row) pl))]);
<strong>double_transposition</strong> :: (RC_board(a) -> RC_board(a)) -> RC_board(a) -> RC_board(a);
double_transposition f b = (transpose_board(f(transpose_board(b))));
<strong>update_board</strong> :: Orientation -> Board -> RRow -> Put_letters_list -> Board;
update_board ot b row pl = (case ot of {
  (Left_right)-> (update_board_2 row pl b);
  (Up_down)-> (double_transposition (update_board_2 row pl) b)
});
<strong>update_board_row</strong> :: Row -> Put_letters_list -> Row;
update_board_row row pl = ((//) row ((map (apply_second Just))(pl)));
<strong>update_board_points_3</strong> :: RRow -> []((CCol, Points)) -> Board_points -> Board_points;
update_board_points_3 row newcol b = ((//) b [(row, ((//) ((!) b row) (map (apply_second Just) newcol)))]);
<strong>update_board_points</strong> :: Orientation -> Board_points -> RRow -> []((CCol, Points)) -> Board_points;
update_board_points ot b row newcol = (case ot of {
  (Left_right)-> (update_board_points_3 row newcol b);
  (Up_down)-> (double_transposition (update_board_points_3 row newcol) b)
});
<strong>type Board_state </strong> = (Board, (Board_points, ()));
<strong>make_board_state</strong> :: Board -> Board_points -> Board_state;
make_board_state b bp = (b, (bp, ()));
<strong>unsorted_plays</strong> :: Tiles_you_have -> Board_state -> [](Essence_of_play);
unsorted_plays current_tiles bs = (let {
<strong>b</strong> :: Board;
b = (fst(bs));
<strong>board_points</strong> :: Board_points;
board_points = (fst(snd(bs)));
<strong>plays_and_scores</strong> :: [](Essence_of_play);
plays_and_scores = ((map (extract_essense Left_right))((zip_map_parallel rnf ((score_result current_tiles board_points) . fst))((scan_plays_one_board b current_tiles))));
<strong>plays_and_scores_2</strong> :: [](Essence_of_play);
plays_and_scores_2 = ((map (extract_essense Up_down))((zip_map_parallel rnf ((score_result current_tiles (transpose_board board_points)) . fst))((scan_plays_one_board (transpose_board b) current_tiles))))
}
 in ((++) plays_and_scores plays_and_scores_2));
<strong>update_board_state</strong> :: Board_state -> Essence_of_play -> Board_state;
update_board_state bs best_play = (make_board_state (update_board (fst(fst(snd(best_play)))) (fst(bs)) (fst(snd(fst(snd(best_play))))) ((map (apply_second fst))(snd(snd(fst(snd(best_play))))))) (update_board_points (fst(fst(snd(best_play)))) (fst(snd(bs))) (fst(snd(fst(snd(best_play))))) ((map (apply_second snd))(snd(snd(fst(snd(best_play))))))));
<strong>best_single_play</strong> :: Tiles_you_have -> Board_state -> (Essence_of_play, Board_state);
best_single_play current_tiles bs = (let {
<strong>best_play</strong> :: Essence_of_play;
best_play = (head((sortBy (comparing fst))((unsorted_plays current_tiles bs))))
}
 in (best_play, (update_board_state bs best_play)));
<strong>data Orientation </strong> = Left_right | Up_down deriving (Show);
<strong>type Ot a</strong> = (Orientation, a);
<strong>type Essence_of_play_1 </strong> = Ot((RRow, []((CCol, (Char, Points)))));
<strong>type Essence_of_play </strong> = (Points, (Essence_of_play_1, Tiles_you_have));
<strong>extract_essense</strong> :: Orientation -> (Play, (Points, Point_col)) -> Essence_of_play;
extract_essense ot x = (let {
<strong>mmm</strong> :: CCol -> Char -> (CCol, (Char, Points));
mmm pos c = (pos, (c, ((!) (snd(snd(x))) pos)))
}
 in ((fst(snd(x))), ((ot, ((fst(fst(fst(fst(x))))), ((map (uncurry mmm))(snd(snd(fst(fst(fst(x))))))))), (snd(fst(x))))));
<strong>read_cap_mchar</strong> :: Char -> Mchar;
read_cap_mchar c = (read_mchar (toLower c));
<strong>read_points</strong> :: Char -> Maybe(Points);
read_points c = (case c of {
  ('.')-> Nothing;
  (_)-> (Just (case (isUpper c) of {
  (True)-> points_blank;
  (_)-> (get_points c)
}))
});
<strong>read_board_state</strong> :: [](String) -> Board_state;
read_board_state ss = (make_board_state (mkboard read_cap_mchar ss) (mkboard read_points ss));
<strong>type Input_state </strong> = ((Tiles_you_have, Board_state), Tiles_you_have);
<strong>parse_state_mine</strong> :: [](String) -> Input_state;
parse_state_mine ss = (let {
<strong>b</strong> :: [](String);
b = (const ((map tail)(init(ss))) "drop first character cuz emacs numbers columns from 0");
<strong>ll</strong> :: [](String);
ll = (words(last(ss)));
<strong>blanks_i_have</strong> :: Int;
blanks_i_have = (read ((!!) ll 0));
<strong>letters_i_have</strong> :: String;
letters_i_have = ((!!) ll 1)
}
 in (((blanks_i_have, (mkarray letters_i_have)), (read_board_state b)), (read_used_tiles b blanks_i_have letters_i_have)));
<strong>template</strong> :: IO(());
template = (putStr(unlines((replicate 15)(((:) (head " "))((replicate 15)(head(".")))))));
<strong>do_move</strong> :: IO(());
do_move = (getContents >>= (putStr . show_list . (map format_1) . (zipWith (let {
<strong>make</strong> :: Int -> Essence_of_play -> (Essence_of_play, Points);
make i e = (e, (Points i))
}
 in make) (enumFrom 1)) . (sortBy (comparing fst)) . (uncurry unsorted_plays) . fst . parse_state_mine . lines));
<strong>tiles_array_to_list</strong> :: Tiles_you_have -> [](Mchar);
tiles_array_to_list t = ((++) (replicate (fst t) Nothing) ((map Just)(concat((map(uncurry(flip(replicate))))(assocs(snd(t)))))));
<strong>tile_list_to_array</strong> :: [](Mchar) -> Tiles_you_have;
tile_list_to_array t = ((length((filter isNothing)(t))), (mkarray(filter_justs(t))));
<strong>run_using_available_tiles</strong> :: [](Mchar) -> [](Mchar) -> Board_state -> ([](Mchar), (Points, Board_state));
run_using_available_tiles available old_current_tiles b = (let {
<strong>num_to_grab</strong> :: Int;
num_to_grab = ((-) max_tiles (length old_current_tiles));
<strong>grab_and_leftover</strong> :: ([](Mchar), [](Mchar));
grab_and_leftover = (splitAt num_to_grab available);
<strong>new_current_tiles</strong> :: Tiles_you_have;
new_current_tiles = (tile_list_to_array(((++) old_current_tiles)(fst(grab_and_leftover))));
<strong>best_play</strong> :: (Essence_of_play, Board_state);
best_play = (best_single_play new_current_tiles b)
}
 in ((snd grab_and_leftover), ((fst (fst best_play)), (snd best_play))));
<strong>two_ply_points</strong> :: [](Mchar) -> Board_state -> [](Mchar) -> (Points, Points);
two_ply_points my_tiles b available = (let {
<strong>opponent_move</strong> :: ([](Mchar), (Points, Board_state));
opponent_move = (run_using_available_tiles available [] b);
<strong>my_move</strong> :: Points;
my_move = (fst(snd((run_using_available_tiles (fst opponent_move) my_tiles (snd (snd opponent_move))))))
}
 in (my_move, (fst(snd(opponent_move)))));
<strong>num_samples</strong> :: Int;
num_samples = 100;
<strong>num_to_process</strong> :: Int;
num_to_process = 8;
<strong>sample_two_plies_io</strong> :: Tiles_you_have -> Board_state -> Points -> [](Mchar) -> IO(Points);
sample_two_plies_io my_tiles b my_points available_tiles = (do{
  r_available :: []([](Mchar)) &lt;- (sequence((replicate num_samples)(random_permutation_IO(available_tiles))));
  (let {
<strong>answer</strong> :: []((Points, Points));
answer = (((flip using) (parList rnf))((map (two_ply_points (tiles_array_to_list my_tiles) b))(r_available)))
}
 in (do{
  (return(sum((map ((+) my_points))((map (uncurry (-)))(answer)))));
}));
});
<strong>call_sample_two_plies_io</strong> :: [](Mchar) -> Board_state -> Essence_of_play -> IO(Points);
call_sample_two_plies_io available_tiles old e = (sample_two_plies_io (snd(snd(e))) (update_board_state old e) (fst(e)) available_tiles);
<strong>print_sample_two_plies</strong> :: [](Mchar) -> Board_state -> Essence_of_play -> IO(());
print_sample_two_plies available_tiles old e = (do{
  answer :: Points &lt;- (call_sample_two_plies_io available_tiles old e);
  (putStrLn(show(format_1((e, answer)))));
});
<strong>read_available_char</strong> :: Char -> [](Mchar);
read_available_char c = (case c of {
  ('.')-> [];
  (_)-> (case (isUpper c) of {
  (True)-> (return Nothing);
  (_)-> (return(Just(c)))
})
});
<strong>read_used_tiles</strong> :: [](String) -> Int -> String -> Tiles_you_have;
read_used_tiles ss blanks_i_have letters_i_have = (let {
<strong>parse_board</strong> :: [](Mchar);
parse_board = ((concatMap read_available_char)(concat(ss)))
}
 in (((+) (length((filter isNothing)(parse_board))) blanks_i_have), (mkarray ((++) (filter_justs parse_board) letters_i_have))));
<strong>total_tiles</strong> :: Tiles_you_have;
total_tiles = (2, (mkarray ("aaaaaaaaab" ++ "bccddddeee" ++ "eeeeeeeeef" ++ "fggghhiiii" ++ "iiiiijklll" ++ "lmmnnnnnno" ++ "oooooooppq" ++ "rrrrrrssss" ++ "ttttttuuuu" ++ "vvwwxyyz")));
<strong>subtract_tiles</strong> :: Tiles_you_have -> Tiles_you_have -> Tiles_you_have;
subtract_tiles big small = (((-) (fst big) (fst small)), (listArray alphabet (zipWith (-) (elems (snd big)) (elems (snd small)))));
<strong>do_move_2</strong> :: ([](Essence_of_play) -> [](Essence_of_play)) -> IO(());
do_move_2 play_sorter = (do{
  (hSetBuffering stdout LineBuffering);
  (setStdGen (mkStdGen 1));
  (putStrLn rcs_code);
  (putStrLn ("num-samples " ++ (show num_samples)));
  fi :: String &lt;- getContents;
  (let {
<strong>available_tiles</strong> :: [](Mchar);
available_tiles = (tiles_array_to_list (subtract_tiles total_tiles (snd(state_mine))));
<strong>current_tiles</strong> :: Tiles_you_have;
current_tiles = (fst(fst(state_mine)));
<strong>state_mine</strong> :: Input_state;
state_mine = (parse_state_mine (lines fi));
<strong>bs</strong> :: Board_state;
bs = (snd(fst(state_mine)));
<strong>plays</strong> :: [](Essence_of_play);
plays = (play_sorter((unsorted_plays current_tiles bs)))
}
 in (do{
  (putStrLn(last(lines(fi))));
  (putStrLn(show(length(plays))));
  (mapM_ (print_sample_two_plies available_tiles bs) plays);
}));
});
<strong>format_1</strong> :: (Essence_of_play, Points) -> (Points, Points, Ot((Coord, String)));
format_1 x = ((snd(x)), (fst(fst(x))), (format_2(fst(snd(fst(x))))));
<strong>format_2</strong> :: Essence_of_play_1 -> Ot((Coord, String));
format_2 x = ((fst x), (((fst(snd(x))), (fst(head(snd(snd(x)))))), ((map (uncurry format_letter))((map snd)(snd(snd(x)))))));
<strong>format_letter</strong> :: Char -> Points -> Char;
format_letter c p = (case p of {
  (Points(0))-> (toUpper c);
  (_)-> c
});
<strong>no_blank_play</strong> :: Essence_of_play -> Bool;
no_blank_play e = (and((map (((/=) (Points 0)) . snd . snd))(snd(snd(fst(snd(e)))))));
<strong>a_play_sorter</strong> :: Int -> [](Essence_of_play) -> [](Essence_of_play);
a_play_sorter skip plays = ((take num_to_process)((drop skip)((sortBy (comparing fst))(plays))));
<strong>go</strong> :: Int -> IO(());
go skip = (do_move_2 (a_play_sorter skip));
<strong>no_blank</strong> :: Int -> IO(());
no_blank skip = (do_move_2 (no_blank_sorter skip));
<strong>no_blank_sorter</strong> :: Int -> [](Essence_of_play) -> [](Essence_of_play);
no_blank_sorter skip plays = ((take num_to_process)((sortBy (comparing fst))((drop skip)((filter no_blank_play)(plays)))))
}