diff options
Diffstat (limited to 'Crosswords.icl')
| -rw-r--r-- | Crosswords.icl | 200 |
1 files changed, 200 insertions, 0 deletions
diff --git a/Crosswords.icl b/Crosswords.icl new file mode 100644 index 0000000..7489545 --- /dev/null +++ b/Crosswords.icl @@ -0,0 +1,200 @@ +module Crosswords + +import StdEnv, StdDebug, StdOverloadedList +import MersenneTwister + +instance + String where (+) x y = x +++ y + +:: HorVer = Hor | Ver + +instance == HorVer +where (==) Hor Hor = True; (==) Ver Ver = True; (==) _ _ = False + +:: WordPlacement + = { word :: [#Char] + , dir :: HorVer + , x :: Int + , y :: Int + } + +:: Crossword :== [WordPlacement] +instance zero Crossword where zero = [] + +:: PlacementOK :== (WordPlacement Crossword -> Bool) + +:: RandomSeed :== Int + +dictionary :== "dict-3-6.txt" + +// Reads words from stdin (end with empty line) and builds a crossword that +// connects all these words (if possible); then fills the crossword with words +// from dict-3-6.txt. Outputs LaTeX code (uses cwpuzzle.dtx from the crossword +// package). +Start w +# (rand,w) = time 0 w +# (fillwords,w) = readFillWords w +# fillwords = sortl fillwords +# (io,w) = stdio w +# (words,io) = readWords [] io +# (ok,w) = fclose io w +# cw = makeCrossword rand words +# cw = fill rand fillwords cw +# cw = trace_n ("\nResult:\n" + toString cw) cw += toLaTeX cw +where + readFillWords :: *World -> *([[#Char]], *World) + readFillWords w + # (ok,f,w) = fopen dictionary FReadText w + | not ok = ([], w) + # (words,f) = readWords [] f + # (ok,w) = fclose f w + = (words,w) + + readWords :: [[#Char]] *File -> *([[#Char]], *File) + readWords acc f + # (s,f) = freadline f + | s == "" = (reverse (map (Map toUpper) acc), f) + # s = fromString` s + | (not o isAlpha o Hd) s = readWords acc f + = readWords [TakeWhile (not o isSpace) s:acc] f + where + fromString` :: String -> [#Char] + fromString` s = fromString s + + time :: !Int !*World -> (!Int, !*World) + time i w = code inline { + ccall time "I:I:p" + } + +minx cw :== minList [wp.x \\ wp <- cw] +miny cw :== minList [wp.y \\ wp <- cw] +maxx cw :== maxList [minx cw:[wp.x+Length wp.word-1 \\ wp<-cw | wp.dir==Hor]] +maxy cw :== maxList [miny cw:[wp.y+Length wp.word-1 \\ wp<-cw | wp.dir==Ver]] + +toLaTeX :: Crossword -> String +toLaTeX cw + = "\\begin{Puzzle}{" + toString width + "}{" + toString height + "}%\n" + + tex (minx cw) (miny cw) 1 (fromString (toString cw)) + + "\\end{Puzzle}\n" +where + width = maxx cw - minx cw + 1 + height = maxy cw - miny cw + 1 + + tex :: Int Int Int [Char] -> String + tex _ _ _ [] = "" + tex x y n [' ':cs] = "|* " + tex (x+1) y n cs + tex x y n ['\n':cs] = "|.\n" + tex (minx cw) (y+1) n cs + tex x y n [c:cs] + | occ (x+1) y && not (occ (x-1) y) || occ x (y+1) && not (occ x (y-1)) + = "|[" + toString n + "]" + {c} + pad + " " + tex (x+1) y (n+1) cs + = "|" + {c} + " " + tex (x+1) y n cs + where pad = if (n>9) "" " " + + occ :: Int Int -> Bool + occ x y = any (any (\(_,x`,y`) -> x`==x && y`==y) o poss) cw + +instance toString Crossword +where + toString cw = foldl (+) "" + [toString + [letter x y \\ x <- [minx cw..maxx cw]] + "\n" + \\ y <- [miny cw..maxy cw]] + where + letter :: Int Int -> Char + letter x y + | isEmpty letters = ' ' + | otherwise = hd letters + where letters = [l \\ w <- cw, (l,x`,y`) <- poss w | x`==x && y`==y] + +// Sort words by decreasing length +sortl :: ([[#Char]] -> [[#Char]]) +sortl = sortBy (\a b -> Length a > Length b) + +// All positions of this letter in this place +letterPositions :: Char WordPlacement -> [(Int,Int)] +letterPositions c wp = [(x,y) \\ (l,x,y) <- poss wp | c == l] + +// All positions a word uses +poss :: WordPlacement -> [(Char,Int,Int)] +poss {word,dir,x,y} + = [if (dir == Hor) (l,x+i,y) (l,x,y+i) \\ l <|- word & i <- [0..]] + +// Fill a crossword with extra words (don't make it bigger) +fill :: RandomSeed ![[#Char]] !Crossword -> Crossword +fill r fws cw = place r fits` (shufflesort r fws) 0 cw + +// Shuffle, then sort on length +shufflesort :: RandomSeed -> [[#Char]] -> [[#Char]] +shufflesort r = sortl o (shuffle r) + +// Shuffle a list of strings semi-randomly +shuffle :: RandomSeed -> [a] -> [a] +shuffle r = s (genRandInt r) +where + s :: [RandomSeed] [a] -> [a] + s _ [] = [] + s [r:rs] xs = [last fsts:s rs (init fsts ++ rest)] + where (fsts,rest) = splitAt (abs (r rem (length xs)) + 1) xs + +// Make a crossword, try to lay all words connected +makeCrossword :: RandomSeed [[#Char]] -> Crossword +makeCrossword r words = place r fits (sortl words) 0 zero + +// Place a number of words in a crossword, satisfying a predicate +place :: RandomSeed PlacementOK [[#Char]] Int Crossword -> Crossword +place _ _ [] _ cw = cw +place r fits ws i cw +| isEmpty places + | i >= length ws - 1 = cw // Nothing can be placed + | otherwise = place r2 fits ws (i+1) cw // Try next words += trace_n word (place r2 fits (removeMember word ws) 0 [hd places:cw]) +where + word = ws!!i + places = placements r1 fits word cw + + [r1,r2:_] = genRandInt r + +// All placements of a word in a crossword that satisfy a predicate +placements :: RandomSeed PlacementOK [#Char] Crossword -> [WordPlacement] +placements _ fits word [] = [{word=word, dir=Hor, x=0, y=0}] +placements r fits word cw = (flatten o flatten) + [[[wp + \\ wp <- [{word=word,dir=Hor,x=x-i,y=y},{word=word,dir=Ver,x=x,y=y-i}] + | fits wp cw] + \\ (x,y) <- letterPositions letter fixedwp] + \\ letter <|- word & i <- [0..], fixedwp <- shuffle r cw] + +// Does a word fit on a crossword? +// Checks that (1) overlapping letters match, (2) no extra words are created, +// (3) words in the same direction are not connected. +fits :: WordPlacement Crossword -> Bool +fits wp cw = f wp cw +where + f :: WordPlacement Crossword -> Bool + f wp [] = True + f wp [wp`:wps] + | any (\(a,b) -> a <> b) overlap = False // (1) + | not (isEmpty overlap) && wp.dir == wp`.dir = False // (3) + | isEmpty overlap && not (isEmpty touching) = False // (2) + | otherwise = f wp wps + where + overlap + = [ (l1,l2) + \\ (l1,x1,y1) <- poss wp, (l2,x2,y2) <- poss wp` + | x1 == x2 && y1 == y2 + ] + touching + = [ 1 // only length is interesting + \\ (l1,x1,y1) <- poss wp, (l2,x2,y2) <- poss wp` + | (abs (x1-x2) == 1 && y1 == y2 || abs (y1-y2) == 1 && x1 == x2) + && all (\wp -> not (isMember (l1,x1,y1) wp)) (map poss cw) + ] + +// Same as fits, but also checks that the crossword's size is not increased +fits` :: WordPlacement Crossword -> Bool +fits` wp=:{x,y,dir,word} cw +| x < minx cw = False +| y < miny cw = False +| dir == Hor && x + Length word - 1 > maxx cw = False +| dir == Ver && y + Length word - 1 > maxy cw = False +| otherwise = fits wp cw |