{-|
  Module      : WordPuzzle
  Description : Word Puzzle supporting functions.
  Copyright   : © Frank Jung, 2017-2026
  License     : BSD-3-Clause
  Maintainer  : frankhjung@linux.com
  Stability   : stable
  Portability : portable

  Supporting functions for solving letter word puzzles.

  == Notes

  Is functions return a boolean:

  > isXyz :: a -> Bool

  Validate functions return a 'Validation':

  > validateXyz :: a -> Validation [ValidationError] a
-}

module WordPuzzle ( WordPuzzle(..)
                  , validateSize
                  , validateLetters
                  , nineLetters
                  , spellingBee
                  , solve
                  , solver
                  , ValidationError(..)
                  , validate
                  , toEither
                  ) where

import           Data.Bits                  (shiftL, (.&.), (.|.))
import           Data.Bool                  (bool)
import qualified Data.ByteString.Char8      as BS
import           Data.Char                  (isLower, ord)
import           Data.Functor.Contravariant (Predicate (..), getPredicate)
import           Data.Ix                    (inRange)
import           Data.List                  (nub)
import           Data.Validation            (Validation (..), toEither)
import qualified System.IO.Streams          as Streams

-- | Represent parameters required for the puzzle.
data WordPuzzle = WordPuzzle
                  {
                    WordPuzzle -> Int
size       :: Int      -- ^ minimum size of words (must be between 4 and 9)
                  , WordPuzzle -> Char
mandatory  :: Char     -- ^ mandatory character in word
                  , WordPuzzle -> String
letters    :: String   -- ^ letters to make words (4–9 unique lowercase characters)
                  , WordPuzzle -> String
dictionary :: FilePath -- ^ dictionary for valid words
                  , WordPuzzle -> Bool
repeats    :: Bool     -- ^ whether letters can be repeated
                  } deriving (Int -> WordPuzzle -> ShowS
[WordPuzzle] -> ShowS
WordPuzzle -> String
(Int -> WordPuzzle -> ShowS)
-> (WordPuzzle -> String)
-> ([WordPuzzle] -> ShowS)
-> Show WordPuzzle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WordPuzzle -> ShowS
showsPrec :: Int -> WordPuzzle -> ShowS
$cshow :: WordPuzzle -> String
show :: WordPuzzle -> String
$cshowList :: [WordPuzzle] -> ShowS
showList :: [WordPuzzle] -> ShowS
Show)

-- | Error given on invalid parameter.
data ValidationError =
    InvalidSize (Int, Int) Int      -- ^ expected range and actual size
    | InvalidLetters String         -- ^ actual letters (should be 4-9 unique lowercase letters)
    | UnexpectedValue String        -- ^ couldn't parse value
    deriving (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq)

-- | Show 'ValidationError' as string.
instance Show ValidationError where
  show :: ValidationError -> String
show (InvalidSize (Int
en1,Int
en2) Int
an)  = String
"expected value in range ("
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
en1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
en2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
an
  show (InvalidLetters String
ls)  = String
"expected 4-9 unique lowercase letters, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ls
  show (UnexpectedValue String
xs) = String
"unexpected value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for parameter"

-- | Validate program parameters.
validate :: Bool -> Int -> String -> FilePath -> Validation [ValidationError] WordPuzzle
validate :: Bool
-> Int
-> String
-> String
-> Validation [ValidationError] WordPuzzle
validate Bool
_ Int
_ [] String
_ = [ValidationError] -> Validation [ValidationError] WordPuzzle
forall err a. err -> Validation err a
Failure [String -> ValidationError
InvalidLetters String
"empty letters"]
validate Bool
r Int
s (Char
m:String
ls) String
d =
  Int -> Char -> String -> String -> Bool -> WordPuzzle
WordPuzzle (Int -> Char -> String -> String -> Bool -> WordPuzzle)
-> Validation [ValidationError] Int
-> Validation
     [ValidationError] (Char -> String -> String -> Bool -> WordPuzzle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Validation [ValidationError] Int
validateSize Int
s         -- validate size
             Validation
  [ValidationError] (Char -> String -> String -> Bool -> WordPuzzle)
-> Validation [ValidationError] Char
-> Validation
     [ValidationError] (String -> String -> Bool -> WordPuzzle)
forall a b.
Validation [ValidationError] (a -> b)
-> Validation [ValidationError] a -> Validation [ValidationError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Validation [ValidationError] Char
forall a. a -> Validation [ValidationError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
m                 -- mandatory letter
             Validation
  [ValidationError] (String -> String -> Bool -> WordPuzzle)
-> Validation [ValidationError] String
-> Validation [ValidationError] (String -> Bool -> WordPuzzle)
forall a b.
Validation [ValidationError] (a -> b)
-> Validation [ValidationError] a -> Validation [ValidationError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Validation [ValidationError] String
validateLetters (Char
mChar -> ShowS
forall a. a -> [a] -> [a]
:String
ls) -- validate letters
             Validation [ValidationError] (String -> Bool -> WordPuzzle)
-> Validation [ValidationError] String
-> Validation [ValidationError] (Bool -> WordPuzzle)
forall a b.
Validation [ValidationError] (a -> b)
-> Validation [ValidationError] a -> Validation [ValidationError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Validation [ValidationError] String
forall a. a -> Validation [ValidationError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
d                 -- dictionary
             Validation [ValidationError] (Bool -> WordPuzzle)
-> Validation [ValidationError] Bool
-> Validation [ValidationError] WordPuzzle
forall a b.
Validation [ValidationError] (a -> b)
-> Validation [ValidationError] a -> Validation [ValidationError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Validation [ValidationError] Bool
forall a. a -> Validation [ValidationError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
r                 -- repeat letters

-- | Validate size of word.
validateSize :: Int -> Validation [ValidationError] Int
validateSize :: Int -> Validation [ValidationError] Int
validateSize Int
s = Validation [ValidationError] Int
-> Validation [ValidationError] Int
-> Bool
-> Validation [ValidationError] Int
forall a. a -> a -> Bool -> a
bool ([ValidationError] -> Validation [ValidationError] Int
forall err a. err -> Validation err a
Failure [(Int, Int) -> Int -> ValidationError
InvalidSize (Int
4,Int
9) Int
s]) (Int -> Validation [ValidationError] Int
forall err a. a -> Validation err a
Success Int
s) (Int -> Bool
isSize Int
s)


-- | Validate letters.
validateLetters :: String -> Validation [ValidationError] String
validateLetters :: String -> Validation [ValidationError] String
validateLetters String
ls = Validation [ValidationError] String
-> Validation [ValidationError] String
-> Bool
-> Validation [ValidationError] String
forall a. a -> a -> Bool -> a
bool ([ValidationError] -> Validation [ValidationError] String
forall err a. err -> Validation err a
Failure [String -> ValidationError
InvalidLetters String
ls]) (String -> Validation [ValidationError] String
forall err a. a -> Validation err a
Success String
ls) (String -> Bool
isLetters String
ls)

-- | Is size valid?  The value must be between 4 and 9 inclusive.
--
-- >>> isSize 9
-- True
--
-- >>> isSize 10
-- False
--
-- >>> isSize 3
-- False
isSize :: Int -> Bool
isSize :: Int -> Bool
isSize = (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
4,Int
9)

-- | Are letters valid?  Valid strings contain between 4 and 9
-- *unique* lowercase letters.
--
-- >>> isLetters "abcd"
-- True
--
-- >>> isLetters "abca"
-- False -- repeated character
--
-- >>> isLetters "abcdefghij"
-- False  -- too long
--
-- >>> isLetters "abcDefg"
-- False -- mixed case
isLetters :: String -> Bool
isLetters :: String -> Bool
isLetters String
ls =
  (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
4,Int
9) Int
n Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLower String
ls Bool -> Bool -> Bool
&& String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ShowS
forall a. Eq a => [a] -> [a]
nub String
ls) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
  where
    n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ls

-- | Does word contain the mandatory letter?
hasMandatory :: Char -> BS.ByteString -> Bool
hasMandatory :: Char -> ByteString -> Bool
hasMandatory = Char -> ByteString -> Bool
BS.elem

-- | Solve word puzzle given a dictionary of words.
--
-- Where each word:
--
-- * must be greater than the minimum word length
-- * must contain mandatory character
-- * must contain only valid characters
-- * if repeats are not allowed, must not exceed valid character frequency
-- * when repeats are enabled there is no upper limit on word length; the word
--   may be longer than the letter pool itself.
--
-- Example:
--
-- @
-- solve (WordPuzzle 4 'a' "abcdefghij" "dictionary.txt")
-- @
--
-- Method:
--
-- * open file
-- * split into lines
-- * filter
-- * print each
-- * force traversal to EOF
solve :: WordPuzzle -> IO ()
solve :: WordPuzzle -> IO ()
solve WordPuzzle
wordpuzzle = String -> (InputStream ByteString -> IO ()) -> IO ()
forall a. String -> (InputStream ByteString -> IO a) -> IO a
Streams.withFileAsInput (WordPuzzle -> String
dictionary WordPuzzle
wordpuzzle) ((InputStream ByteString -> IO ()) -> IO ())
-> (InputStream ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InputStream ByteString
is -> do
  InputStream ByteString
lines_is <- InputStream ByteString -> IO (InputStream ByteString)
Streams.lines InputStream ByteString
is
  InputStream ByteString
filtered_is <- WordPuzzle -> InputStream ByteString -> IO (InputStream ByteString)
solver WordPuzzle
wordpuzzle InputStream ByteString
lines_is
  InputStream ByteString
printed_is <- (ByteString -> IO ())
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> IO b) -> InputStream a -> IO (InputStream a)
Streams.mapM_ ByteString -> IO ()
BS.putStrLn InputStream ByteString
filtered_is
  InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
printed_is

-- | Filter words from an input stream based on the puzzle constraints.
solver :: WordPuzzle -> Streams.InputStream BS.ByteString -> IO (Streams.InputStream BS.ByteString)
solver :: WordPuzzle -> InputStream ByteString -> IO (InputStream ByteString)
solver WordPuzzle
puzzle = (ByteString -> Bool)
-> InputStream ByteString -> IO (InputStream ByteString)
forall a. (a -> Bool) -> InputStream a -> IO (InputStream a)
Streams.filter (Predicate ByteString -> ByteString -> Bool
forall a. Predicate a -> a -> Bool
getPredicate (Predicate ByteString
pS Predicate ByteString
-> Predicate ByteString -> Predicate ByteString
forall a. Semigroup a => a -> a -> a
<> Predicate ByteString
pM Predicate ByteString
-> Predicate ByteString -> Predicate ByteString
forall a. Semigroup a => a -> a -> a
<> Predicate ByteString
pL))
  where
    pS :: Predicate ByteString
pS = (ByteString -> Bool) -> Predicate ByteString
forall a. (a -> Bool) -> Predicate a
Predicate ((ByteString -> Bool) -> Predicate ByteString)
-> (ByteString -> Bool) -> Predicate ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> ByteString -> Bool
checkLength (WordPuzzle -> Bool
repeats WordPuzzle
puzzle) (WordPuzzle -> Int
size WordPuzzle
puzzle)
    pM :: Predicate ByteString
pM = (ByteString -> Bool) -> Predicate ByteString
forall a. (a -> Bool) -> Predicate a
Predicate ((ByteString -> Bool) -> Predicate ByteString)
-> (ByteString -> Bool) -> Predicate ByteString
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> Bool
hasMandatory (WordPuzzle -> Char
mandatory WordPuzzle
puzzle)
    pL :: Predicate ByteString
pL = (ByteString -> Bool) -> Predicate ByteString
forall a. (a -> Bool) -> Predicate a
Predicate ((ByteString -> Bool) -> Predicate ByteString)
-> (ByteString -> Bool) -> Predicate ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> String -> ByteString -> Bool
checkLettersPool (WordPuzzle -> Bool
repeats WordPuzzle
puzzle) (WordPuzzle -> String
letters WordPuzzle
puzzle)

-- | Check word length based on whether repeats are allowed.
checkLength :: Bool -- ^ allow repeats?
            -> Int  -- ^ minimum word size
            -> BS.ByteString -- ^ word to check
            -> Bool -- ^ true if word length is valid
checkLength :: Bool -> Int -> ByteString -> Bool
checkLength Bool
True  Int
s = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
s) (Int -> Bool) -> (ByteString -> Int) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length
checkLength Bool
False Int
s = (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
s, Int
9) (Int -> Bool) -> (ByteString -> Int) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length

-- | Check if a word matches the letter pool based on whether repeats
-- are allowed.
--
-- Assumes that the letter pool is valid (see 'isLetters').
checkLettersPool :: Bool -- ^ allow repeats?
                  -> String -- ^ valid letters in letter pool
                  -> BS.ByteString -- ^ word to check
                  -> Bool -- ^ true if word matches letter pool
checkLettersPool :: Bool -> String -> ByteString -> Bool
checkLettersPool Bool
True  String
ls = String -> ByteString -> Bool
spellingBee String
ls
checkLettersPool Bool
False String
ls = String -> ByteString -> Bool
nineLetters String
ls

-- | Check if a word contains only characters from a letters list.
--
-- Uses a strict left fold over the input word with accumulator @(mask, ok)@:
--
-- * @mask@ is a bitset of already seen letters.
--
-- * @ok@ tracks whether all checks have passed so far.
--
-- For each character, the fold:
--
-- * fails if the character is not in the valid letter pool,
--
-- * fails if the character bit is already set (repeated letter),
--
-- * otherwise sets the bit and continues.
--
-- Assumes that the letter pool is valid (see 'isLetters').
nineLetters ::
     String        -- ^ valid letters
  -> BS.ByteString -- ^ dictionary word to check
  -> Bool          -- ^ true if dictionary word matches letters
nineLetters :: String -> ByteString -> Bool
nineLetters String
ls = (Int, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Int, Bool) -> Bool)
-> (ByteString -> (Int, Bool)) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Bool) -> Char -> (Int, Bool))
-> (Int, Bool) -> ByteString -> (Int, Bool)
forall a. (a -> Char -> a) -> a -> ByteString -> a
BS.foldl' (Int, Bool) -> Char -> (Int, Bool)
forall {a}. (Bits a, Num a) => (a, Bool) -> Char -> (a, Bool)
step (Int
0 :: Int, Bool
True)
  where
    step :: (a, Bool) -> Char -> (a, Bool)
step (a
mask, Bool
ok) Char
c
      | Bool -> Bool
not Bool
ok            = (a
mask, Bool
False) -- already failed, skip checks
      | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
ls    = (a
mask, Bool
False) -- character not in letter pool
      | a
mask a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
bit a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 = (a
mask, Bool
False) -- character already seen (repeated)
      | Bool
otherwise         = (a
mask a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
bit, Bool
True) -- continue with bit set
      where
        bit :: a
bit = a
1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a')  -- bit position for character

-- | Check if a word contains only characters from a letters list.
-- Repeating characters are allowed.
--
-- Assumes that the letter pool is valid (see 'isLetters').
spellingBee ::
     String        -- ^ valid letters
  -> BS.ByteString -- ^ dictionary word to check
  -> Bool          -- ^ true if dictionary word matches letters
spellingBee :: String -> ByteString -> Bool
spellingBee String
ls = (Char -> Bool) -> ByteString -> Bool
BS.all (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ls)