{-# LANGUAGE TupleSections, NamedFieldPuns, BinaryLiterals, TemplateHaskell, CPP, ScopedTypeVariables, NumericUnderscores, FlexibleInstances #-}

{-# LANGUAGE StrictData, BangPatterns #-}
{-# OPTIONS_GHC -O #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- no observable effect from these
{-# OPTIONS_GHC -fspecialise-aggressively #-} -- no observable effect from these

{-# LANGUAGE RankNTypes #-} -- for maybeSet

{-# OPTIONS_GHC -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-type-defaults -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- complains about unused lenses :/

-- json
{-# LANGUAGE DeriveGeneric #-}

{-|
Module      : Pipemaze
Description : solves pipe mazes
Copyright   : (c) siers
License     : GPL-3
Maintainer  : wimuan@email.com
Stability   : experimental
Portability : POSIX

A dynamic solver of pipe mazes with an internal 'priority' queue based on scores, position and priority creation order and much more.
-}

module Pipemaze (
  -- * High-level description
  -- $description

  -- * Islands
  -- $islands

  -- * Bugs and improvements
  -- $bugs

  -- * Types
  Direction, Rotation, Pix, Cursor, Fursor, MMaze(..), Piece(..), Choices, PartId, Continue(..)
  , Priority, Continues, Components(..), Unwind(..), Progress(..), Island(..), IslandSolution(..)
  , Bounds, SolveMode(..), Configuration(..), Solver, SolverT
  -- * Maze operations
  , parse, mazeStore, mazeBounded, mazeCursor, mazeFursor, mazeRead, mazeModify
  , mazeClone, mazeSolve, mazeDelta, mazeFDelta, mazeEquate, mazePop, partEquate
  -- * Tracing and rendering
  , renderColor, renderStr, renderImage'
  , traceBoard
  -- * Pixel model
  , directions, rotations, charMap, pixMap, pixRotations, pixDirections, directionsPix, toPix, toChar, rotate
  -- * Pixel solving
  , pixValid, validateDirection, pieceChoices
  -- * Component indexing
  , compInsert, compRemove, compEquate, compAlive, compConnected, compCounts
  -- * Continue operations
  , deltaContinue, prioritizeDeltas, rescoreContinue, prioritizeContinue, prioritizeContinues
  , pieceDead, findContinue, popContinue
  -- * Island computations
  , FillNext, flood, islandize, islandConnectivityRefinement, islandChoices, islands
  -- * Backtracker
  , solveContinue, backtrack, solve'
  -- * Metasolver
  , islandChoicesParallel, solveDetParallel, initProgress, solve
  -- * Main
  , verify, storeBad, rotateStr, configuration, pļāpātArWebsocketu, solveFile, main
) where

-- solver

-- Lens TemplateHaskell
import Control.Lens.Internal.FieldTH (makeFieldOptics, LensRules(..))
import Language.Haskell.TH.Syntax (mkName, nameBase)
import Control.Lens.TH (DefName(..), lensRules)

-- Solver
import Algebra.PartialOrd (PartialOrd(..))
import Control.Concurrent (getNumCapabilities)
import Control.Lens (Setter', (&), (%~), set, _1, _2, _head, _Just)
import Control.Monad.Extra (allM, whenM)
import Control.Monad.IO.Class (MonadIO(..), liftIO)
import Control.Monad (join, filterM, void, unless, when, mfilter, replicateM, (<=<))
import Control.Monad.Primitive (RealWorld)
import Control.Monad.Reader (MonadReader(..), Reader, ReaderT(..), ask, asks, withReaderT, mapReaderT)
import Control.Monad.Trans.State.Strict (StateT(..))
import Data.Char (ord)
import Data.Foldable (traverse_, for_, foldlM, fold)
import Data.Function (on)
import Data.Functor.Identity (Identity(..), runIdentity)
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import Data.List.Extra (nubOrd, groupSort, groupSortOn, splitOn, chunksOf, intersperse, transpose)
import Data.Map.Strict (Map, (!))
import Data.Maybe (fromMaybe, fromJust, isJust, maybeToList)
import Data.Monoid (Sum(..))
import Data.Set (Set)
import Data.Traversable (for)
import Data.Tuple (swap)
import Data.Vector.Storable.Mutable (IOVector)
import Data.Word (Word8)
-- import Debug.Trace (trace)
import Foreign.Storable.Generic
import Graphics.Image.Interface (thaw, MImage, freeze, write)
import Graphics.Image (writeImage, makeImageR, Pixel(..), toPixelRGB, VU(..), RGB)
import Numeric (showHex)
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Bits as Bit
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.POSet as POSet
import qualified Data.Set as Set
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as MV
import System.Clock (getTime, Clock(Monotonic), diffTimeSpec, toNanoSecs, TimeSpec)
import System.Environment (lookupEnv, getArgs)
import System.Directory (createDirectoryIfMissing)
import Text.Printf (printf)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)

-- parallel
import Control.Concurrent.ParallelIO.Global (parallelInterleaved)

-- json for debug outputs
import Data.Aeson (ToJSON(..))
-- import qualified Data.Aeson as Aeson
-- import qualified Data.ByteString.Lazy.Char8 as LBS
import GHC.Generics (Generic)

-- Main IO
import Data.Text (Text)
import Network.Socket (withSocketsDo)
import qualified Data.Text as T
import qualified Network.WebSockets as WS
import System.IO (hFlush, stdout)

-- t a = seq (trace (show a) a) a
-- t' l a = seq (trace (show l ++ ": " ++ show a) a) a
-- tM :: (Functor f, Show a) => f a -> f a
-- tM = fmap t

-- $description
-- The goal of the solver is to find the 'Rotation' of each 'Pix' in the grid to create a connected undirected graph.
-- Just like in this game here: <https://www.puzzle-pipes.com/>
--
-- * Each cursor has four nearby cursors – top, right, bottom, left, which wil be refered to as 'directions' or 'deltas'.
-- * The 'Cursor's in one square's distance in a 'direction' with respect to some cursor @c@ may also be called 'deltas'.
-- * The number of valid rotations of a piece are encoded in 'Choices'.
-- * Each 'Piece' contains initial 'Choices' which are bit-packed info 'initChoices',
-- * Distinct graphs are being refered to as /components/ and each has a distinct 'PartId' computed by the smallest 'Fursor' of the graph.
--  <https://en.wikipedia.org/wiki/Component_(graph_theory)>
-- * All 'Component\''s open ends are refered to as 'Continue's,
--  which then later get stored in 'Continue' to make a piece "active", making 'Piece' information is no longer necessary.
-- * The cursors are stored as flat indexes ('Fursor') to make comparison computations faster ('IntMap'). Conversions to 'Cursor'
--  are possible via 'mazeCursor', 'mazeFursor'.
-- * 'Progress' holds main data of the backtracker, the only mutable data is 'MMaze', which stores correctly solved 'Pix' and
--  'partId's which get updated as graphs become joined.
--
-- Solving each piece gives you hints about surrounding pieces,
-- so solving them by diagonals ('rescoreContinue') is more effective than solving in an arbitrary order.
-- If the connectivity of the pieces is efficiently computed ('PartId' \/ 'partEquate'),
-- the "open ends" ('Continues') have a good prioritization and the disconnected solves are efficiently (computed
-- and then) discarded ('pieceDead' \/ 'compAlive'), you can solve around 98% of the level 6 maze determinstically.

-- $islands
-- Island is a patch of unsolved pieces, each one has its own number of solutions.
-- Solving it by backtracking makes the search space multiply after guessing one island after another in a single 'Progress'.
-- Instead, you can force the backtracker to only count the solutions of a single island with 'cBounds'.
-- If you group the solutions ('islandConnectivityRefinement'), many islands have a single best or equivalent solution.
-- 'solveTrivialIslands' runs the backtracker for all "simple" islands, then recomputes all islands, then repeats.
-- The even simpler 'solveIslandStatic' solves all the pieces that remain the same in all 'IslandSolution's.
-- Running either solves level 6 very fast and 'solveIslandStatic' (+ 'solve') is a little faster.
--
-- Grouping in 'islandConnectivityRefinement' takes place in two steps: group by equal 'Components',
-- refine 'icConnections' by their partition 'PartialOrd'.

-- $bugs
-- * `partId`/`origin` is a little awkward, but `pipe`/`char` is even more so
-- * 'Continue's can be removed, if their old versions are added in 'Unwind's
-- * A separate priority list could be mae for choices = 1
-- * All 'IslandSolution's are getting recomputed after each determinstic solve, which can be fixed, but it's already very fast
-- * 'IslandSolution' could be recomputable without running main solver,
--  just by checking that nothing gets disconnected after running it through all the 'Unwind's of last solve.
-- * Backtracking on 'IslandSolution' could be implemented
-- * 'IslandSolution's could be chosen by just checking that the 'icConnections' connect some graph constructed from islands.
-- * 'IslandSolution' could have a heuristic for the number of solutions without solving all
--  solutions by solving in breadth-wise first choices – '[Progress]' and only then depth-wise.

-- | Directions: top 0, right 1, bottom 2, left 3
type Direction = Int
-- | The set of rotation values are the same as directions.
type Rotation = Int
-- | The maze symbol (has four edges) bit-packed in 'charMap' as @2^d@ per direction, mirrored in @shiftL 4@ to help bit rotation
--
-- > X – ╋          -- 4 edges
-- > I – ━, ┃       -- 2 edges
-- > L – ┏, ┛, ┓, ┗ -- 2 edges
-- > T – ┣, ┫, ┳, ┻ -- 3 edges
-- > i – ╸, ╹, ╺, ╻ -- 1 edge
type Pix = Word8
type Cursor = (Int, Int)
-- | Flat cursors, for @f :: FCursor, (x, y) :: Cursor, f = x + y * width@. Through `Choices`, bound checking is cached, so deltas are just ±1 or ±width.
type Width = Int
type Fursor = Int

-- | unlawful instance
instance Eq (IOVector Piece) where _ == :: IOVector Piece -> IOVector Piece -> Bool
== _ = Bool
True
-- | unlawful instance
instance Ord (IOVector Piece) where _ <= :: IOVector Piece -> IOVector Piece -> Bool
<= _ = Bool
True

-- | Mutable maze operated on by functions in section /"Maze operations"/
data MMaze = MMaze
  { MMaze -> IOVector Piece
board :: IOVector Piece -- ^ flat MVector with implied 2d structure via 'Cursor'/'Fursor' + index computations
  , MMaze -> Int
width :: Int
  , MMaze -> Int
height :: Int
  , MMaze -> Int
size :: Int
  , MMaze -> Int
sizeLen :: Int -- ^ leading char count for @printf %0ni@ format @(~logBase 10 size + 1.5)@
  , MMaze -> Int
level :: Int
  , MMaze -> [Int]
trivials :: [Fursor] -- ^ cursors of the edge and @X@ pieces which have only one valid rotation
  , MMaze -> String
mazeId :: String -- ^ 'board's data scrambled into a 4-byte hexadecimal field
  , MMaze -> TimeSpec
time :: TimeSpec
  } deriving (MMaze -> MMaze -> Bool
(MMaze -> MMaze -> Bool) -> (MMaze -> MMaze -> Bool) -> Eq MMaze
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MMaze -> MMaze -> Bool
$c/= :: MMaze -> MMaze -> Bool
== :: MMaze -> MMaze -> Bool
$c== :: MMaze -> MMaze -> Bool
Eq, Eq MMaze
Eq MMaze =>
(MMaze -> MMaze -> Ordering)
-> (MMaze -> MMaze -> Bool)
-> (MMaze -> MMaze -> Bool)
-> (MMaze -> MMaze -> Bool)
-> (MMaze -> MMaze -> Bool)
-> (MMaze -> MMaze -> MMaze)
-> (MMaze -> MMaze -> MMaze)
-> Ord MMaze
MMaze -> MMaze -> Bool
MMaze -> MMaze -> Ordering
MMaze -> MMaze -> MMaze
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MMaze -> MMaze -> MMaze
$cmin :: MMaze -> MMaze -> MMaze
max :: MMaze -> MMaze -> MMaze
$cmax :: MMaze -> MMaze -> MMaze
>= :: MMaze -> MMaze -> Bool
$c>= :: MMaze -> MMaze -> Bool
> :: MMaze -> MMaze -> Bool
$c> :: MMaze -> MMaze -> Bool
<= :: MMaze -> MMaze -> Bool
$c<= :: MMaze -> MMaze -> Bool
< :: MMaze -> MMaze -> Bool
$c< :: MMaze -> MMaze -> Bool
compare :: MMaze -> MMaze -> Ordering
$ccompare :: MMaze -> MMaze -> Ordering
$cp1Ord :: Eq MMaze
Ord, (forall x. MMaze -> Rep MMaze x)
-> (forall x. Rep MMaze x -> MMaze) -> Generic MMaze
forall x. Rep MMaze x -> MMaze
forall x. MMaze -> Rep MMaze x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MMaze x -> MMaze
$cfrom :: forall x. MMaze -> Rep MMaze x
Generic)

data Piece = Piece
  { Piece -> Pix
pipe :: Pix
  , Piece -> Bool
solved :: Bool
  , Piece -> Int
partId :: PartId -- ^ meaningless if not connected
  , Piece -> Bool
connected :: Bool -- ^ connected when pointed to by a 'solved' piece
  , Piece -> Int
initChoices :: Choices
  } deriving (Int -> Piece -> ShowS
[Piece] -> ShowS
Piece -> String
(Int -> Piece -> ShowS)
-> (Piece -> String) -> ([Piece] -> ShowS) -> Show Piece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Piece] -> ShowS
$cshowList :: [Piece] -> ShowS
show :: Piece -> String
$cshow :: Piece -> String
showsPrec :: Int -> Piece -> ShowS
$cshowsPrec :: Int -> Piece -> ShowS
Show, Piece -> Piece -> Bool
(Piece -> Piece -> Bool) -> (Piece -> Piece -> Bool) -> Eq Piece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Piece -> Piece -> Bool
$c/= :: Piece -> Piece -> Bool
== :: Piece -> Piece -> Bool
$c== :: Piece -> Piece -> Bool
Eq, Eq Piece
Eq Piece =>
(Piece -> Piece -> Ordering)
-> (Piece -> Piece -> Bool)
-> (Piece -> Piece -> Bool)
-> (Piece -> Piece -> Bool)
-> (Piece -> Piece -> Bool)
-> (Piece -> Piece -> Piece)
-> (Piece -> Piece -> Piece)
-> Ord Piece
Piece -> Piece -> Bool
Piece -> Piece -> Ordering
Piece -> Piece -> Piece
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Piece -> Piece -> Piece
$cmin :: Piece -> Piece -> Piece
max :: Piece -> Piece -> Piece
$cmax :: Piece -> Piece -> Piece
>= :: Piece -> Piece -> Bool
$c>= :: Piece -> Piece -> Bool
> :: Piece -> Piece -> Bool
$c> :: Piece -> Piece -> Bool
<= :: Piece -> Piece -> Bool
$c<= :: Piece -> Piece -> Bool
< :: Piece -> Piece -> Bool
$c< :: Piece -> Piece -> Bool
compare :: Piece -> Piece -> Ordering
$ccompare :: Piece -> Piece -> Ordering
$cp1Ord :: Eq Piece
Ord, (forall x. Piece -> Rep Piece x)
-> (forall x. Rep Piece x -> Piece) -> Generic Piece
forall x. Rep Piece x -> Piece
forall x. Piece -> Rep Piece x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Piece x -> Piece
$cfrom :: forall x. Piece -> Rep Piece x
Generic)

instance GStorable Piece

-- | 'Choices' is bit-packed info related to the valid rotations of a picce.
-- In MSB order: (valid) rotation count 2b, invalid rotation directions 4b (unused), solved requirements 4b, solved neighbours 4b
type Choices = Int
(choicesSolveds :: Int
choicesSolveds, choicesInvalid :: Int
choicesInvalid, choicesCount :: Int
choicesCount) = (0, 4, 8)

-- | Continue represents the piece that should be solved next according to 'Priority', which is an open end of a component
-- (or starts one). Created in 'initProgress' or 'deltaContinue'.
data Continue = Continue
  { Continue -> Int
cursor :: Fursor
  , Continue -> Pix
char :: Pix -- ^ from Piece at 'cursor'
  , Continue -> Int
origin :: PartId -- ^ component id, to be used with 'partEquate'
  , Continue -> Int
score :: Int -- ^ see 'rescoreContinue'
  , Continue -> Int
created :: Int -- ^ any unique id to make score order total ('Ord' requirement), taken from 'iter'
  , Continue -> Int
island :: Int -- ^ \> 0 if island
  , Continue -> Int
area :: Int -- ^ island score, 0 if not an island
  , Continue -> Int
choices :: Choices
  } deriving (Int -> Continue -> ShowS
[Continue] -> ShowS
Continue -> String
(Int -> Continue -> ShowS)
-> (Continue -> String) -> ([Continue] -> ShowS) -> Show Continue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Continue] -> ShowS
$cshowList :: [Continue] -> ShowS
show :: Continue -> String
$cshow :: Continue -> String
showsPrec :: Int -> Continue -> ShowS
$cshowsPrec :: Int -> Continue -> ShowS
Show, Continue -> Continue -> Bool
(Continue -> Continue -> Bool)
-> (Continue -> Continue -> Bool) -> Eq Continue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Continue -> Continue -> Bool
$c/= :: Continue -> Continue -> Bool
== :: Continue -> Continue -> Bool
$c== :: Continue -> Continue -> Bool
Eq, Eq Continue
Eq Continue =>
(Continue -> Continue -> Ordering)
-> (Continue -> Continue -> Bool)
-> (Continue -> Continue -> Bool)
-> (Continue -> Continue -> Bool)
-> (Continue -> Continue -> Bool)
-> (Continue -> Continue -> Continue)
-> (Continue -> Continue -> Continue)
-> Ord Continue
Continue -> Continue -> Bool
Continue -> Continue -> Ordering
Continue -> Continue -> Continue
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Continue -> Continue -> Continue
$cmin :: Continue -> Continue -> Continue
max :: Continue -> Continue -> Continue
$cmax :: Continue -> Continue -> Continue
>= :: Continue -> Continue -> Bool
$c>= :: Continue -> Continue -> Bool
> :: Continue -> Continue -> Bool
$c> :: Continue -> Continue -> Bool
<= :: Continue -> Continue -> Bool
$c<= :: Continue -> Continue -> Bool
< :: Continue -> Continue -> Bool
$c< :: Continue -> Continue -> Bool
compare :: Continue -> Continue -> Ordering
$ccompare :: Continue -> Continue -> Ordering
$cp1Ord :: Eq Continue
Ord, (forall x. Continue -> Rep Continue x)
-> (forall x. Rep Continue x -> Continue) -> Generic Continue
forall x. Rep Continue x -> Continue
forall x. Continue -> Rep Continue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Continue x -> Continue
$cfrom :: forall x. Continue -> Rep Continue x
Generic)

-- | 'PartId' distinguishes the graph component by their smallest known 'Cursor' by its 'Ord' (unique),
-- so it is the same as its cursor initially. They're marked in 'origin' ahead of 'solved's.
-- 'PartId' in 'origin' is only to be used through 'partEquate', because 'origin' isn't being
-- updated after components have connected.
type PartId = Fursor

-- | 'Continue' priority queue, inserted by 'prioritizeContinue', found by 'findContinue', popped by 'popContinue'.
type Priority = IntMap Fursor
-- | Primary storage of 'Continue' data
type Continues = IntMap Continue
-- | The index of components' continues by their 'PartId' (which are always up-to-date).
data Components
  = Components (IntMap Int) -- ^ marginally faster, but less info
  | Components' (IntMap IntSet)
  deriving (Int -> Components -> ShowS
[Components] -> ShowS
Components -> String
(Int -> Components -> ShowS)
-> (Components -> String)
-> ([Components] -> ShowS)
-> Show Components
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Components] -> ShowS
$cshowList :: [Components] -> ShowS
show :: Components -> String
$cshow :: Components -> String
showsPrec :: Int -> Components -> ShowS
$cshowsPrec :: Int -> Components -> ShowS
Show, Components -> Components -> Bool
(Components -> Components -> Bool)
-> (Components -> Components -> Bool) -> Eq Components
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Components -> Components -> Bool
$c/= :: Components -> Components -> Bool
== :: Components -> Components -> Bool
$c== :: Components -> Components -> Bool
Eq, Eq Components
Eq Components =>
(Components -> Components -> Ordering)
-> (Components -> Components -> Bool)
-> (Components -> Components -> Bool)
-> (Components -> Components -> Bool)
-> (Components -> Components -> Bool)
-> (Components -> Components -> Components)
-> (Components -> Components -> Components)
-> Ord Components
Components -> Components -> Bool
Components -> Components -> Ordering
Components -> Components -> Components
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Components -> Components -> Components
$cmin :: Components -> Components -> Components
max :: Components -> Components -> Components
$cmax :: Components -> Components -> Components
>= :: Components -> Components -> Bool
$c>= :: Components -> Components -> Bool
> :: Components -> Components -> Bool
$c> :: Components -> Components -> Bool
<= :: Components -> Components -> Bool
$c<= :: Components -> Components -> Bool
< :: Components -> Components -> Bool
$c< :: Components -> Components -> Bool
compare :: Components -> Components -> Ordering
$ccompare :: Components -> Components -> Ordering
$cp1Ord :: Eq Components
Ord, (forall x. Components -> Rep Components x)
-> (forall x. Rep Components x -> Components) -> Generic Components
forall x. Rep Components x -> Components
forall x. Components -> Rep Components x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Components x -> Components
$cfrom :: forall x. Components -> Rep Components x
Generic)

type Space = [([(Continue, Progress)], [Unwind])]

-- | For backtracking on the mutable 'MMaze' and for extracting hints.
data Unwind
  = UnSolve Fursor Pix Pix -- ^ 'Pix' before, after (for deployHint)
  | UnEquate Fursor Bool PartId -- ^ 'connected', 'PartId' after
  deriving (Int -> Unwind -> ShowS
[Unwind] -> ShowS
Unwind -> String
(Int -> Unwind -> ShowS)
-> (Unwind -> String) -> ([Unwind] -> ShowS) -> Show Unwind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unwind] -> ShowS
$cshowList :: [Unwind] -> ShowS
show :: Unwind -> String
$cshow :: Unwind -> String
showsPrec :: Int -> Unwind -> ShowS
$cshowsPrec :: Int -> Unwind -> ShowS
Show, Unwind -> Unwind -> Bool
(Unwind -> Unwind -> Bool)
-> (Unwind -> Unwind -> Bool) -> Eq Unwind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unwind -> Unwind -> Bool
$c/= :: Unwind -> Unwind -> Bool
== :: Unwind -> Unwind -> Bool
$c== :: Unwind -> Unwind -> Bool
Eq, Eq Unwind
Eq Unwind =>
(Unwind -> Unwind -> Ordering)
-> (Unwind -> Unwind -> Bool)
-> (Unwind -> Unwind -> Bool)
-> (Unwind -> Unwind -> Bool)
-> (Unwind -> Unwind -> Bool)
-> (Unwind -> Unwind -> Unwind)
-> (Unwind -> Unwind -> Unwind)
-> Ord Unwind
Unwind -> Unwind -> Bool
Unwind -> Unwind -> Ordering
Unwind -> Unwind -> Unwind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Unwind -> Unwind -> Unwind
$cmin :: Unwind -> Unwind -> Unwind
max :: Unwind -> Unwind -> Unwind
$cmax :: Unwind -> Unwind -> Unwind
>= :: Unwind -> Unwind -> Bool
$c>= :: Unwind -> Unwind -> Bool
> :: Unwind -> Unwind -> Bool
$c> :: Unwind -> Unwind -> Bool
<= :: Unwind -> Unwind -> Bool
$c<= :: Unwind -> Unwind -> Bool
< :: Unwind -> Unwind -> Bool
$c< :: Unwind -> Unwind -> Bool
compare :: Unwind -> Unwind -> Ordering
$ccompare :: Unwind -> Unwind -> Ordering
$cp1Ord :: Eq Unwind
Ord, (forall x. Unwind -> Rep Unwind x)
-> (forall x. Rep Unwind x -> Unwind) -> Generic Unwind
forall x. Rep Unwind x -> Unwind
forall x. Unwind -> Rep Unwind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Unwind x -> Unwind
$cfrom :: forall x. Unwind -> Rep Unwind x
Generic)

data Progress = Progress
  { Progress -> Int
iter :: Int -- ^ the total number of backtracking iterations (incl. failed ones)
  , Progress -> Int
depth :: Int -- ^ number of solves, so also the length of unwinds/space
  , Progress -> Priority
priority :: Priority -- ^ priority queue for next guesses (tree, not a heap, because reprioritizing is required)
  , Progress -> Continues
continues :: Continues -- ^ Primary continue store, pointed to by 'priority' (all 'Continue's within must be unique by their cursor)
  , Progress -> Components
components :: Components -- ^ component continue counts (for quickly computing disconnected components via `compAlive`)
  , Progress -> Space
space :: Space -- ^ backtracking's "rewind" + unexplored solution stack; an item per a solve. pop when (last 'space' == [])
  , Progress -> MMaze
maze :: MMaze
  } deriving (Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq, Eq Progress
Eq Progress =>
(Progress -> Progress -> Ordering)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Progress)
-> (Progress -> Progress -> Progress)
-> Ord Progress
Progress -> Progress -> Bool
Progress -> Progress -> Ordering
Progress -> Progress -> Progress
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Progress -> Progress -> Progress
$cmin :: Progress -> Progress -> Progress
max :: Progress -> Progress -> Progress
$cmax :: Progress -> Progress -> Progress
>= :: Progress -> Progress -> Bool
$c>= :: Progress -> Progress -> Bool
> :: Progress -> Progress -> Bool
$c> :: Progress -> Progress -> Bool
<= :: Progress -> Progress -> Bool
$c<= :: Progress -> Progress -> Bool
< :: Progress -> Progress -> Bool
$c< :: Progress -> Progress -> Bool
compare :: Progress -> Progress -> Ordering
$ccompare :: Progress -> Progress -> Ordering
$cp1Ord :: Eq Progress
Ord, (forall x. Progress -> Rep Progress x)
-> (forall x. Rep Progress x -> Progress) -> Generic Progress
forall x. Rep Progress x -> Progress
forall x. Progress -> Rep Progress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Progress x -> Progress
$cfrom :: forall x. Progress -> Rep Progress x
Generic)

type PrioCompCont = (Priority, Components, Continues)

-- | unlawful
instance Show Progress where
  show :: Progress -> String
show Progress{Int
depth :: Int
depth :: Progress -> Int
depth, Int
iter :: Int
iter :: Progress -> Int
iter} =
    "Progress" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Char, Int) -> String
forall a. Show a => a -> String
show (Int
depth, '/', Int
iter)

type Bounds = Maybe (Fursor -> Bool)

bounded :: Bounds -> Fursor -> Bool
bounded :: Bounds -> Int -> Bool
bounded b :: Bounds
b c :: Int
c = ((Int -> Bool) -> Bool) -> Bounds -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int
c) Bounds
b

-- | Amalgamation of the flags "determinstic", "save history" and "deprioritize unbounded continues"
-- (it's for parallelism, see 'rescoreContinue').
data SolveMode = SolveNormal | SolveDeterministic | SolveIslandDeterministic | SolveParallel deriving (Int -> SolveMode -> ShowS
[SolveMode] -> ShowS
SolveMode -> String
(Int -> SolveMode -> ShowS)
-> (SolveMode -> String)
-> ([SolveMode] -> ShowS)
-> Show SolveMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SolveMode] -> ShowS
$cshowList :: [SolveMode] -> ShowS
show :: SolveMode -> String
$cshow :: SolveMode -> String
showsPrec :: Int -> SolveMode -> ShowS
$cshowsPrec :: Int -> SolveMode -> ShowS
Show, SolveMode -> SolveMode -> Bool
(SolveMode -> SolveMode -> Bool)
-> (SolveMode -> SolveMode -> Bool) -> Eq SolveMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SolveMode -> SolveMode -> Bool
$c/= :: SolveMode -> SolveMode -> Bool
== :: SolveMode -> SolveMode -> Bool
$c== :: SolveMode -> SolveMode -> Bool
Eq, Eq SolveMode
Eq SolveMode =>
(SolveMode -> SolveMode -> Ordering)
-> (SolveMode -> SolveMode -> Bool)
-> (SolveMode -> SolveMode -> Bool)
-> (SolveMode -> SolveMode -> Bool)
-> (SolveMode -> SolveMode -> Bool)
-> (SolveMode -> SolveMode -> SolveMode)
-> (SolveMode -> SolveMode -> SolveMode)
-> Ord SolveMode
SolveMode -> SolveMode -> Bool
SolveMode -> SolveMode -> Ordering
SolveMode -> SolveMode -> SolveMode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SolveMode -> SolveMode -> SolveMode
$cmin :: SolveMode -> SolveMode -> SolveMode
max :: SolveMode -> SolveMode -> SolveMode
$cmax :: SolveMode -> SolveMode -> SolveMode
>= :: SolveMode -> SolveMode -> Bool
$c>= :: SolveMode -> SolveMode -> Bool
> :: SolveMode -> SolveMode -> Bool
$c> :: SolveMode -> SolveMode -> Bool
<= :: SolveMode -> SolveMode -> Bool
$c<= :: SolveMode -> SolveMode -> Bool
< :: SolveMode -> SolveMode -> Bool
$c< :: SolveMode -> SolveMode -> Bool
compare :: SolveMode -> SolveMode -> Ordering
$ccompare :: SolveMode -> SolveMode -> Ordering
$cp1Ord :: Eq SolveMode
Ord)

solveDeterministic :: SolveMode -> Bool
solveDeterministic SolveNormal = Bool
True
solveDeterministic _ = Bool
False

solveWithHistory :: SolveMode -> Bool
solveWithHistory SolveNormal = Bool
True
solveWithHistory SolveIslandDeterministic = Bool
False -- could be True if you plan to solve islands directly (reply unwinds)
solveWithHistory _ = Bool
False

data Configuration = Configuration
  { Configuration -> Int
cDebug :: Int
  , Configuration -> Int
cDebugFreq :: Int
  , Configuration -> Int
cPixSize :: Int
  , Configuration -> Int
cLifespan :: Int
  , Configuration -> SolveMode
cMode :: SolveMode
  , Configuration -> Bounds
cBounds :: Bounds -- ^ forces the solver to stay within bounds
  , Configuration -> Bool
cBench :: Bool
  , Configuration -> String
cImageDir :: String
  , Configuration -> Int
cNumCap :: Int
  } -- deriving (Show, Eq, Ord, Generic)

type SolverT = ReaderT Configuration IO
type Solver = Reader Configuration

-- | Island is the patch of unsolved pieces surrounded by solved pieces, computed by 'flood' in 'islands'.
data Island = Island
  { Island -> Int
iId :: Int
  , Island -> Int
iSize :: Int
  , Island -> [Continue]
iConts :: [Continue]
  , Island -> IntSet
iBounds :: IntSet
  , Island -> [IslandSolution]
iSolutions :: [IslandSolution]
  -- ^ all possible combinations (partitioned by partition equivalence), with hints to force solver choose that solve
  , Island -> Int
iChoices :: Int -- ^ same, but without details
  } deriving (Int -> Island -> ShowS
[Island] -> ShowS
Island -> String
(Int -> Island -> ShowS)
-> (Island -> String) -> ([Island] -> ShowS) -> Show Island
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Island] -> ShowS
$cshowList :: [Island] -> ShowS
show :: Island -> String
$cshow :: Island -> String
showsPrec :: Int -> Island -> ShowS
$cshowsPrec :: Int -> Island -> ShowS
Show, Island -> Island -> Bool
(Island -> Island -> Bool)
-> (Island -> Island -> Bool) -> Eq Island
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Island -> Island -> Bool
$c/= :: Island -> Island -> Bool
== :: Island -> Island -> Bool
$c== :: Island -> Island -> Bool
Eq, Eq Island
Eq Island =>
(Island -> Island -> Ordering)
-> (Island -> Island -> Bool)
-> (Island -> Island -> Bool)
-> (Island -> Island -> Bool)
-> (Island -> Island -> Bool)
-> (Island -> Island -> Island)
-> (Island -> Island -> Island)
-> Ord Island
Island -> Island -> Bool
Island -> Island -> Ordering
Island -> Island -> Island
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Island -> Island -> Island
$cmin :: Island -> Island -> Island
max :: Island -> Island -> Island
$cmax :: Island -> Island -> Island
>= :: Island -> Island -> Bool
$c>= :: Island -> Island -> Bool
> :: Island -> Island -> Bool
$c> :: Island -> Island -> Bool
<= :: Island -> Island -> Bool
$c<= :: Island -> Island -> Bool
< :: Island -> Island -> Bool
$c< :: Island -> Island -> Bool
compare :: Island -> Island -> Ordering
$ccompare :: Island -> Island -> Ordering
$cp1Ord :: Eq Island
Ord, (forall x. Island -> Rep Island x)
-> (forall x. Rep Island x -> Island) -> Generic Island
forall x. Rep Island x -> Island
forall x. Island -> Rep Island x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Island x -> Island
$cfrom :: forall x. Island -> Rep Island x
Generic)

-- | IslandSolution represent a solution for an island with a representative progress.
-- The 'icConnections' are a partition of the components the island joined.
-- Partitions have a partial ordering called _refinement_ with which you can group 'iSolutions'.
-- <https://en.wikipedia.org/wiki/Partition_of_a_set#Refinement_of_partitions>
data IslandSolution = IslandSolution
  -- { icProgess :: Progress
  { IslandSolution -> [Set Int]
icConnections :: [Set PartId] -- the surrounding 'PartId' partition (induces a PartialOrd)
  , IslandSolution -> Priority
icComponents :: IntMap Int
  , IslandSolution -> [Unwind]
icHints :: [Unwind] -- ^ forces the backtracker to choose this solution
  } deriving (Int -> IslandSolution -> ShowS
[IslandSolution] -> ShowS
IslandSolution -> String
(Int -> IslandSolution -> ShowS)
-> (IslandSolution -> String)
-> ([IslandSolution] -> ShowS)
-> Show IslandSolution
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IslandSolution] -> ShowS
$cshowList :: [IslandSolution] -> ShowS
show :: IslandSolution -> String
$cshow :: IslandSolution -> String
showsPrec :: Int -> IslandSolution -> ShowS
$cshowsPrec :: Int -> IslandSolution -> ShowS
Show, IslandSolution -> IslandSolution -> Bool
(IslandSolution -> IslandSolution -> Bool)
-> (IslandSolution -> IslandSolution -> Bool) -> Eq IslandSolution
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IslandSolution -> IslandSolution -> Bool
$c/= :: IslandSolution -> IslandSolution -> Bool
== :: IslandSolution -> IslandSolution -> Bool
$c== :: IslandSolution -> IslandSolution -> Bool
Eq, Eq IslandSolution
Eq IslandSolution =>
(IslandSolution -> IslandSolution -> Ordering)
-> (IslandSolution -> IslandSolution -> Bool)
-> (IslandSolution -> IslandSolution -> Bool)
-> (IslandSolution -> IslandSolution -> Bool)
-> (IslandSolution -> IslandSolution -> Bool)
-> (IslandSolution -> IslandSolution -> IslandSolution)
-> (IslandSolution -> IslandSolution -> IslandSolution)
-> Ord IslandSolution
IslandSolution -> IslandSolution -> Bool
IslandSolution -> IslandSolution -> Ordering
IslandSolution -> IslandSolution -> IslandSolution
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IslandSolution -> IslandSolution -> IslandSolution
$cmin :: IslandSolution -> IslandSolution -> IslandSolution
max :: IslandSolution -> IslandSolution -> IslandSolution
$cmax :: IslandSolution -> IslandSolution -> IslandSolution
>= :: IslandSolution -> IslandSolution -> Bool
$c>= :: IslandSolution -> IslandSolution -> Bool
> :: IslandSolution -> IslandSolution -> Bool
$c> :: IslandSolution -> IslandSolution -> Bool
<= :: IslandSolution -> IslandSolution -> Bool
$c<= :: IslandSolution -> IslandSolution -> Bool
< :: IslandSolution -> IslandSolution -> Bool
$c< :: IslandSolution -> IslandSolution -> Bool
compare :: IslandSolution -> IslandSolution -> Ordering
$ccompare :: IslandSolution -> IslandSolution -> Ordering
$cp1Ord :: Eq IslandSolution
Ord, (forall x. IslandSolution -> Rep IslandSolution x)
-> (forall x. Rep IslandSolution x -> IslandSolution)
-> Generic IslandSolution
forall x. Rep IslandSolution x -> IslandSolution
forall x. IslandSolution -> Rep IslandSolution x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IslandSolution x -> IslandSolution
$cfrom :: forall x. IslandSolution -> Rep IslandSolution x
Generic)

instance PartialOrd IslandSolution where
  IslandSolution{icConnections :: IslandSolution -> [Set Int]
icConnections=[Set Int]
as} leq :: IslandSolution -> IslandSolution -> Bool
`leq` IslandSolution{icConnections :: IslandSolution -> [Set Int]
icConnections=[Set Int]
bs} =
    (Set Int -> Bool) -> [Set Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (((Set Int -> Bool) -> [Set Int] -> Bool)
-> [Set Int] -> (Set Int -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set Int -> Bool) -> [Set Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [Set Int]
bs ((Set Int -> Bool) -> Bool)
-> (Set Int -> Set Int -> Bool) -> Set Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf) [Set Int]
as

makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''MMaze
makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''Piece
makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''Continue
makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''Progress
makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''Configuration
makeFieldOptics lensRules { _fieldToDef = \_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase } ''Island

toSolverT :: ReaderT r Identity b -> ReaderT r IO b
toSolverT = (Identity b -> IO b) -> ReaderT r Identity b -> ReaderT r IO b
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> (Identity b -> b) -> Identity b -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b -> b
forall a. Identity a -> a
runIdentity)
determinstically :: ReaderT Configuration m a -> ReaderT Configuration m a
determinstically = (Configuration -> Configuration)
-> ReaderT Configuration m a -> ReaderT Configuration m a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (ASetter Configuration Configuration SolveMode SolveMode
-> SolveMode -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Configuration Configuration SolveMode SolveMode
Lens' Configuration SolveMode
cModeL SolveMode
SolveDeterministic)
determinsticallyI :: ReaderT Configuration m a -> ReaderT Configuration m a
determinsticallyI = (Configuration -> Configuration)
-> ReaderT Configuration m a -> ReaderT Configuration m a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (ASetter Configuration Configuration SolveMode SolveMode
-> SolveMode -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Configuration Configuration SolveMode SolveMode
Lens' Configuration SolveMode
cModeL SolveMode
SolveIslandDeterministic) -- for islands, see withHistory

confDefault :: Configuration
confDefault = $WConfiguration :: Int
-> Int
-> Int
-> Int
-> SolveMode
-> Bounds
-> Bool
-> String
-> Int
-> Configuration
Configuration
  { cDebug :: Int
cDebug = 0
  , cDebugFreq :: Int
cDebugFreq = 10377
  , cPixSize :: Int
cPixSize = 3
  , cLifespan :: Int
cLifespan = - 1
  , cMode :: SolveMode
cMode = SolveMode
SolveNormal
  , cBounds :: Bounds
cBounds = Bounds
forall a. Maybe a
Nothing
  , cBench :: Bool
cBench = Bool
False
  , cImageDir :: String
cImageDir = "images/"
  , cNumCap :: Int
cNumCap = 1
  }

-- | unlawful
instance Show MMaze where
  -- | unlawful instance
  show :: MMaze -> String
show _ = "MMaze"

instance ToJSON Piece
instance ToJSON Continue
instance ToJSON Components
instance ToJSON Island
instance ToJSON Unwind
instance ToJSON IslandSolution
-- writeFile "out" . LBS.unpack . Aeson.encode . toJSON $ solutions

-- | https://hackage.haskell.org/package/monad-extras-0.6.0/docs/src/Control-Monad-Extra.html#iterateMaybeM
-- | Monadic equivalent to 'iterate', which uses Maybe to know when to terminate.
iterateMaybeM :: Monad m => Int -> (a -> m (Maybe a)) -> a -> m (Bool, [a])
iterateMaybeM :: Int -> (a -> m (Maybe a)) -> a -> m (Bool, [a])
iterateMaybeM 0 _ _ = (Bool, [a]) -> m (Bool, [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [])
iterateMaybeM n :: Int
n f :: a -> m (Maybe a)
f x :: a
x = ([a] -> (Bool, [a])) -> m [a] -> m (Bool, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
False, ) (m [a] -> m (Bool, [a])) -> m [a] -> m (Bool, [a])
forall a b. (a -> b) -> a -> b
$
  m [a] -> (a -> m [a]) -> Maybe a -> m [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (\x' :: a
x' -> ((a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ((Bool, [a]) -> [a]) -> (Bool, [a]) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, [a]) -> [a]
forall a b. (a, b) -> b
snd) ((Bool, [a]) -> [a]) -> m (Bool, [a]) -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> (a -> m (Maybe a)) -> a -> m (Bool, [a])
forall (m :: * -> *) a.
Monad m =>
Int -> (a -> m (Maybe a)) -> a -> m (Bool, [a])
iterateMaybeM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) a -> m (Maybe a)
f a
x') (Maybe a -> m [a]) -> m (Maybe a) -> m [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m (Maybe a)
f a
x

{--- MMaze and Matrix operations ---}

parse :: String -> IO MMaze
parse :: String -> IO MMaze
parse input :: String
input = do
  TimeSpec
time <- Clock -> IO TimeSpec
getTime Clock
Monotonic
  MMaze
maze <- (\b :: IOVector Piece
b -> IOVector Piece
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> String
-> TimeSpec
-> MMaze
MMaze IOVector Piece
b Int
width Int
height Int
size Int
zeros Int
level [] String
mazeId TimeSpec
time) (IOVector Piece -> MMaze) -> IO (IOVector Piece) -> IO MMaze
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Piece -> IO (MVector (PrimState IO) Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
V.thaw ([Piece] -> Vector Piece
forall a. Storable a => [a] -> Vector a
V.fromList (((Int, Piece) -> Piece) -> [(Int, Piece)] -> [Piece]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Piece) -> Piece
forall a b. (a, b) -> b
snd [(Int, Piece)]
board))
  (\m :: MMaze
m -> ([Int] -> IO [Int]) -> MMaze -> IO MMaze
Lens' MMaze [Int]
trivialsL (IO [Int] -> [Int] -> IO [Int]
forall a b. a -> b -> a
const (MMaze -> IO [Int]
trivials MMaze
m)) MMaze
m) (MMaze -> IO MMaze) -> IO MMaze -> IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IOVector Piece -> IO (IOVector Piece)) -> MMaze -> IO MMaze
Lens' MMaze (IOVector Piece)
boardL (IO (IOVector Piece) -> IOVector Piece -> IO (IOVector Piece)
forall a b. a -> b -> a
const (MMaze -> IO (IOVector Piece)
setDeltas MMaze
maze)) (MMaze -> IO MMaze) -> IO MMaze -> IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> IO MMaze
forall (f :: * -> *) a. Applicative f => a -> f a
pure MMaze
maze
  where
    mazeId :: String
mazeId = Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex ((Char -> Int -> Int) -> Int -> String -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: Char
a b :: Int
b -> (Char -> Int
ord Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (2 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ 16)) 0 String
input) ""
    [[Pix]]
rect :: [[Pix]] = ([Pix] -> Bool) -> [[Pix]] -> [[Pix]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Pix] -> Bool) -> [Pix] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pix] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Pix]] -> [[Pix]]) -> (String -> [[Pix]]) -> String -> [[Pix]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [Pix]) -> [String] -> [[Pix]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Pix) -> String -> [Pix]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pix
toPix) ([String] -> [[Pix]]) -> (String -> [String]) -> String -> [[Pix]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [[Pix]]) -> String -> [[Pix]]
forall a b. (a -> b) -> a -> b
$ String
input
    board :: [(Int, Piece)]
board = (Int -> Pix -> (Int, Piece)) -> [Int] -> [Pix] -> [(Int, Piece)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Int, Pix) -> (Int, Piece)) -> Int -> Pix -> (Int, Piece)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Int, Pix) -> (Int, Piece)
piece) [0..] ([Pix] -> [(Int, Piece)])
-> ([[Pix]] -> [Pix]) -> [[Pix]] -> [(Int, Piece)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pix]] -> [Pix]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Pix]] -> [(Int, Piece)]) -> [[Pix]] -> [(Int, Piece)]
forall a b. (a -> b) -> a -> b
$ [[Pix]]
rect
    piece :: (Int, Pix) -> (Int, Piece)
piece (fc :: Int
fc, p :: Pix
p) = (Int
fc, Pix -> Bool -> Int -> Bool -> Int -> Piece
Piece Pix
p Bool
False Int
fc Bool
False 0)

    (width :: Int
width, height :: Int
height) = ([Pix] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Pix]] -> [Pix]
forall a. [a] -> a
head [[Pix]]
rect), [[Pix]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Pix]]
rect)
    size :: Int
size = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height
    zeros :: Int
zeros = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 10 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ 1.5)
    level :: Int
level = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 7 (Int -> [(Int, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
size [(64,1), (500,2), (2_500,3), (20_000,4), (120_000,5), (1_000_000,6)])

    setDeltas :: MMaze -> IO (IOVector Piece)
setDeltas m :: MMaze
m = Vector Piece -> IO (IOVector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
V.thaw (Vector Piece -> IO (IOVector Piece))
-> ([Piece] -> Vector Piece) -> [Piece] -> IO (IOVector Piece)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Piece] -> Vector Piece
forall a. Storable a => [a] -> Vector a
V.fromList ([Piece] -> IO (IOVector Piece))
-> IO [Piece] -> IO (IOVector Piece)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Int, Piece) -> IO Piece) -> [(Int, Piece)] -> IO [Piece]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(fc :: Int
fc, p :: Piece
p) -> (Int -> IO Int) -> Piece -> IO Piece
Lens' Piece Int
initChoicesL (IO Int -> Int -> IO Int
forall a b. a -> b -> a
const (MMaze -> (Int, Piece) -> IO Int
forall b. MMaze -> (Int, b) -> IO Int
choices MMaze
m (Int
fc, Piece
p))) Piece
p) [(Int, Piece)]
board
    choices :: MMaze -> (Int, b) -> IO Int
choices m :: MMaze
m (fc :: Int
fc, _p :: b
_p) = do
      let c :: (Int, Int)
c = Int -> Int -> (Int, Int)
mazeCursor Int
width Int
fc
      Int
choices <- MMaze -> (Int, Int) -> IO Int
pieceChoices MMaze
m (Int, Int)
c
      let next :: [Int]
next = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> (Int, Int) -> Bool
mazeBounded' Int
width Int
height ((Int, Int) -> Bool) -> (Int -> (Int, Int)) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int -> (Int, Int)
mazeDelta (Int, Int)
c) [Int]
directions
      Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
choices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall i. Integral i => [Int] -> i
directionsPix [Int]
next)

    trivials :: MMaze -> IO [Fursor]
    trivials :: MMaze -> IO [Int]
trivials MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board} = ((Int, Piece) -> Int) -> [(Int, Piece)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Piece) -> Int
forall a b. (a, b) -> a
fst ([(Int, Piece)] -> [Int])
-> (Vector Piece -> [(Int, Piece)]) -> Vector Piece -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Piece) -> Bool) -> [(Int, Piece)] -> [(Int, Piece)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Piece) -> Bool
forall a. (a, Piece) -> Bool
trivial ([(Int, Piece)] -> [(Int, Piece)])
-> (Vector Piece -> [(Int, Piece)])
-> Vector Piece
-> [(Int, Piece)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Piece] -> [(Int, Piece)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([Piece] -> [(Int, Piece)])
-> (Vector Piece -> [Piece]) -> Vector Piece -> [(Int, Piece)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Piece -> [Piece]
forall a. Storable a => Vector a -> [a]
V.toList (Vector Piece -> [Int]) -> IO (Vector Piece) -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Piece -> IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState IO) Piece
board
    trivial :: (a, Piece) -> Bool
trivial (_, Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
initChoices :: Int
initChoices :: Piece -> Int
initChoices}) = Pix
pipe Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
== 0b11111111 Bool -> Bool -> Bool
|| Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftR Int
initChoices Int
choicesCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2

mazeStore :: MonadIO m => MMaze -> String -> m ()
mazeStore :: MMaze -> String -> m ()
mazeStore m :: MMaze
m label :: String
label = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
writeFile String
label (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> IO String
renderStr MMaze
m)

{-# INLINE mazeBounded #-}
mazeBounded :: MMaze -> Cursor -> Bool
mazeBounded :: MMaze -> (Int, Int) -> Bool
mazeBounded MMaze{Int
width :: Int
width :: MMaze -> Int
width, Int
height :: Int
height :: MMaze -> Int
height} = Int -> Int -> (Int, Int) -> Bool
mazeBounded' Int
width Int
height

mazeBounded' :: Int -> Int -> Cursor -> Bool
mazeBounded' :: Int -> Int -> (Int, Int) -> Bool
mazeBounded' width :: Int
width height :: Int
height (!Int
x, !Int
y) = Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
x Bool -> Bool -> Bool
&& Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
y

vectorLists :: Storable a => Int -> Int -> V.Vector a -> [[a]]
vectorLists :: Int -> Int -> Vector a -> [[a]]
vectorLists width :: Int
width height :: Int
height board :: Vector a
board = [ [ Vector a
board Vector a -> Int -> a
forall a. Storable a => Vector a -> Int -> a
V.! (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) | Int
x <- [0..Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ] | Int
y <- [0..Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ]

{-# INLINE mazeCursor #-}
mazeCursor :: Width -> Fursor -> Cursor
mazeCursor :: Int -> Int -> (Int, Int)
mazeCursor width :: Int
width = (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap ((Int, Int) -> (Int, Int))
-> (Int -> (Int, Int)) -> Int -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem Int
width

{-# INLINE mazeFursor #-}
mazeFursor :: Width -> Cursor -> Fursor
mazeFursor :: Int -> (Int, Int) -> Int
mazeFursor w :: Int
w (x :: Int
x, y :: Int
y) = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w

{-# INLINE mazeRead #-}
mazeRead :: MonadIO m => MMaze -> Fursor -> m Piece
mazeRead :: MMaze -> Int -> m Piece
mazeRead MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board} fc :: Int
fc = IO Piece -> m Piece
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVector (PrimState IO) Piece -> Int -> IO Piece
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead IOVector Piece
MVector (PrimState IO) Piece
board Int
fc)

{-# INLINE mazeModify #-}
mazeModify :: MonadIO m => MMaze -> (Piece -> Piece) -> Fursor -> m ()
mazeModify :: MMaze -> (Piece -> Piece) -> Int -> m ()
mazeModify MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board} f :: Piece -> Piece
f fc :: Int
fc = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Piece -> (Piece -> Piece) -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.unsafeModify IOVector Piece
MVector (PrimState IO) Piece
board Piece -> Piece
f Int
fc

mazeClone :: MonadIO m => MMaze -> m MMaze
mazeClone :: MMaze -> m MMaze
mazeClone = IO MMaze -> m MMaze
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MMaze -> m MMaze) -> (MMaze -> IO MMaze) -> MMaze -> m MMaze
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOVector Piece -> IO (IOVector Piece)) -> MMaze -> IO MMaze
Lens' MMaze (IOVector Piece)
boardL IOVector Piece -> IO (IOVector Piece)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> m (MVector (PrimState m) a)
MV.clone

{-# INLINE mazeSolve #-}
mazeSolve :: MonadIO m => MMaze -> Continue -> m Unwind
mazeSolve :: MMaze -> Continue -> m Unwind
mazeSolve MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board} Continue{char :: Continue -> Pix
char=Pix
after, Int
cursor :: Int
cursor :: Continue -> Int
cursor} = do
  p :: Piece
p@Piece{pipe :: Piece -> Pix
pipe=Pix
before} <- IO Piece -> m Piece
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVector (PrimState IO) Piece -> Int -> IO Piece
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead IOVector Piece
MVector (PrimState IO) Piece
board Int
cursor)
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Piece -> Int -> Piece -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite IOVector Piece
MVector (PrimState IO) Piece
board Int
cursor Piece
p { pipe :: Pix
pipe = Pix
after, solved :: Bool
solved = Bool
True }
  Unwind -> m Unwind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Pix -> Pix -> Unwind
UnSolve Int
cursor Pix
before Pix
after)

{-# INLINE mazeDelta #-}
mazeDelta :: Cursor -> Direction -> Cursor
mazeDelta :: (Int, Int) -> Int -> (Int, Int)
mazeDelta (x :: Int
x, y :: Int
y) 0 = (Int
x, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
mazeDelta (x :: Int
x, y :: Int
y) 1 = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
y)
mazeDelta (x :: Int
x, y :: Int
y) 2 = (Int
x, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
mazeDelta (x :: Int
x, y :: Int
y) 3 = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, Int
y)
mazeDelta _ _      = String -> (Int, Int)
forall a. HasCallStack => String -> a
error "wrong direction"

{-# INLINE mazeFDelta #-}
mazeFDelta :: Int -> Fursor -> Direction -> Fursor
mazeFDelta :: Int -> Int -> Int -> Int
mazeFDelta w :: Int
w f :: Int
f 0 = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w
mazeFDelta _ f :: Int
f 1 = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
mazeFDelta w :: Int
w f :: Int
f 2 = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w
mazeFDelta _ f :: Int
f 3 = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
mazeFDelta _ _ _  = String -> Int
forall a. HasCallStack => String -> a
error "wrong direction"

mazeDeltasWalls :: MMaze -> Cursor -> IO [(Piece, Direction)]
mazeDeltasWalls :: MMaze -> (Int, Int) -> IO [(Piece, Int)]
mazeDeltasWalls m :: MMaze
m c :: (Int, Int)
c = (Int -> IO (Piece, Int)) -> [Int] -> IO [(Piece, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (MMaze -> (Int, Int) -> Int -> IO (Piece, Int)
mazeDeltaWall MMaze
m (Int, Int)
c) [Int]
directions

{-# INLINE mazeDeltaWall #-}
mazeDeltaWall :: MMaze -> Cursor -> Direction -> IO (Piece, Direction)
mazeDeltaWall :: MMaze -> (Int, Int) -> Int -> IO (Piece, Int)
mazeDeltaWall m :: MMaze
m@MMaze{Int
width :: Int
width :: MMaze -> Int
width} c :: (Int, Int)
c dir :: Int
dir =
  if MMaze -> (Int, Int) -> Bool
mazeBounded MMaze
m (Int, Int)
delta
  then (, Int
dir) (Piece -> (Piece, Int)) -> IO Piece -> IO (Piece, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
m (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)
  else (Piece, Int) -> IO (Piece, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pix -> Bool -> Int -> Bool -> Int -> Piece
Piece 0 Bool
True 0 Bool
True 0, Int
dir)
  where delta :: (Int, Int)
delta@(x :: Int
x, y :: Int
y) = (Int, Int) -> Int -> (Int, Int)
mazeDelta (Int, Int)
c Int
dir

{-# INLINE mazeEquate #-}
-- | Connects 'PartId's on the board
mazeEquate :: MonadIO m => MMaze -> PartId -> [Fursor] -> m [Unwind]
mazeEquate :: MMaze -> Int -> [Int] -> m [Unwind]
mazeEquate MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board} partId :: Int
partId cursors :: [Int]
cursors = IO [Unwind] -> m [Unwind]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Unwind] -> m [Unwind]) -> IO [Unwind] -> m [Unwind]
forall a b. (a -> b) -> a -> b
$
  [Int] -> (Int -> IO Unwind) -> IO [Unwind]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int]
cursors ((Int -> IO Unwind) -> IO [Unwind])
-> (Int -> IO Unwind) -> IO [Unwind]
forall a b. (a -> b) -> a -> b
$ \cursor :: Int
cursor -> do
    p :: Piece
p@Piece{Bool
connected :: Bool
connected :: Piece -> Bool
connected, partId :: Piece -> Int
partId=Int
partId_} <- IO Piece -> IO Piece
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVector (PrimState IO) Piece -> Int -> IO Piece
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead IOVector Piece
MVector (PrimState IO) Piece
board Int
cursor)
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Piece -> Int -> Piece -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite IOVector Piece
MVector (PrimState IO) Piece
board Int
cursor Piece
p { Int
partId :: Int
partId :: Int
partId, connected :: Bool
connected = Bool
True }
    Unwind -> IO Unwind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Bool -> Int -> Unwind
UnEquate Int
cursor Bool
connected Int
partId_)

{-# INLINE mazePop #-}
mazePop :: MonadIO m => MMaze -> Unwind -> m ()
mazePop :: MMaze -> Unwind -> m ()
mazePop m :: MMaze
m (UnSolve c :: Int
c pipe :: Pix
pipe _) = MMaze -> (Piece -> Piece) -> Int -> m ()
forall (m :: * -> *).
MonadIO m =>
MMaze -> (Piece -> Piece) -> Int -> m ()
mazeModify MMaze
m (\p :: Piece
p -> Piece
p { Pix
pipe :: Pix
pipe :: Pix
pipe, solved :: Bool
solved = Bool
False }) Int
c
mazePop m :: MMaze
m (UnEquate c :: Int
c connected :: Bool
connected partId :: Int
partId) = MMaze -> (Piece -> Piece) -> Int -> m ()
forall (m :: * -> *).
MonadIO m =>
MMaze -> (Piece -> Piece) -> Int -> m ()
mazeModify MMaze
m (\p :: Piece
p -> Piece
p { Int
partId :: Int
partId :: Int
partId, Bool
connected :: Bool
connected :: Bool
connected }) Int
c

-- | Looks up the fixed point of 'PartId' (i.e. when it points to itself)
{-# INLINE partEquate #-}
partEquate :: MonadIO m => MMaze -> PartId -> m PartId
partEquate :: MMaze -> Int -> m Int
partEquate maze :: MMaze
maze v :: Int
v = Int -> m Int
forall (m :: * -> *). MonadIO m => Int -> m Int
loop' (Int -> m Int) -> m Int -> m Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> m Int
forall (m :: * -> *). MonadIO m => Int -> m Int
find Int
v
  where
    find :: Int -> f Int
find f :: Int
f = (\Piece{Bool
connected :: Bool
connected :: Piece -> Bool
connected, Int
partId :: Int
partId :: Piece -> Int
partId} -> if Bool
connected then Int
partId else Int
f) (Piece -> Int) -> f Piece -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> f Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze Int
f
    loop' :: Int -> m Int
loop' v' :: Int
v' = (\found :: Int
found -> if Int
v' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v Bool -> Bool -> Bool
|| Int
v' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
found then Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
v' else Int -> m Int
loop' Int
found) (Int -> m Int) -> m Int -> m Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> m Int
forall (m :: * -> *). MonadIO m => Int -> m Int
find Int
v'

{--- Rendering, tracing ---}

-- | Generate uncolorized output
renderStr :: MMaze -> IO String
renderStr :: MMaze -> IO String
renderStr MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board, Int
width :: Int
width :: MMaze -> Int
width, Int
height :: Int
height :: MMaze -> Int
height} =
  [String] -> String
unlines ([String] -> String)
-> (Vector Piece -> [String]) -> Vector Piece -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Piece] -> String) -> [[Piece]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Piece -> String) -> [Piece] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> (Piece -> Char) -> Piece -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pix -> Char
toChar (Pix -> Char) -> (Piece -> Pix) -> Piece -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Pix
pipe)) ([[Piece]] -> [String])
-> (Vector Piece -> [[Piece]]) -> Vector Piece -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Vector Piece -> [[Piece]]
forall a. Storable a => Int -> Int -> Vector a -> [[a]]
vectorLists Int
width Int
height (Vector Piece -> [[Piece]])
-> (Vector Piece -> Vector Piece) -> Vector Piece -> [[Piece]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Piece -> Vector Piece
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
V.convert (Vector Piece -> String) -> IO (Vector Piece) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Piece -> IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState IO) Piece
board

{- HLINT ignore renderImageN -}
renderImageN :: MonadIO m => Int -> String -> MMaze -> Continues -> m ()
renderImageN :: Int -> String -> MMaze -> Continues -> m ()
renderImageN pixSize :: Int
pixSize fn :: String
fn maze :: MMaze
maze@MMaze{Int
width :: Int
width :: MMaze -> Int
width, Int
height :: Int
height :: MMaze -> Int
height} continues :: Continues
continues = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Continues -> IO () -> IO ()
forall a b. a -> b -> b
seq Continues
continues (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  MImage RealWorld VU RGB Double
mcanvas <- Image VU RGB Double -> IO (MImage (PrimState IO) VU RGB Double)
forall arr cs e (m :: * -> *).
(MArray arr cs e, Functor m, PrimMonad m) =>
Image arr cs e -> m (MImage (PrimState m) arr cs e)
thaw Image VU RGB Double
canvas :: IO (MImage RealWorld VU RGB Double)
  ((Int, Int) -> IO ()) -> [(Int, Int)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MImage RealWorld VU RGB Double -> (Int, Int) -> IO ()
drawPiece MImage RealWorld VU RGB Double
mcanvas) [(Int, Int)]
grid
  String -> Image VU RGB Double -> IO ()
forall cs e arr.
(Array VS cs e, Array arr cs e,
 Writable (Image VS cs e) OutputFormat) =>
String -> Image arr cs e -> IO ()
writeImage String
fn (Image VU RGB Double -> IO ()) -> IO (Image VU RGB Double) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MImage (PrimState IO) VU RGB Double -> IO (Image VU RGB Double)
forall arr cs e (m :: * -> *).
(MArray arr cs e, Functor m, PrimMonad m) =>
MImage (PrimState m) arr cs e -> m (Image arr cs e)
freeze MImage RealWorld VU RGB Double
MImage (PrimState IO) VU RGB Double
mcanvas
  where
    (pixW :: Int
pixW, pixH :: Int
pixH) = (Int
pixSize, Int
pixSize)
    border :: Int
border = Int
pixSize
    canvas :: Image VU RGB Double
canvas = VU
-> (Int, Int)
-> ((Int, Int) -> Pixel RGB Double)
-> Image VU RGB Double
forall arr cs e.
Array arr cs e =>
arr -> (Int, Int) -> ((Int, Int) -> Pixel cs e) -> Image arr cs e
makeImageR VU
VU ((Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixW, (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixH) (((Int, Int) -> Pixel RGB Double) -> Image VU RGB Double)
-> ((Int, Int) -> Pixel RGB Double) -> Image VU RGB Double
forall a b. (a -> b) -> a -> b
$ Pixel RGB Double -> (Int, Int) -> Pixel RGB Double
forall a b. a -> b -> a
const (Double -> Double -> Double -> Pixel RGB Double
forall e. e -> e -> e -> Pixel RGB e
PixelRGB 0 0 0)
    grid :: [(Int, Int)]
grid = (,) (Int -> Int -> (Int, Int)) -> [Int] -> [Int -> (Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [0..Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] [Int -> (Int, Int)] -> [Int] -> [(Int, Int)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [0..Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]

    colorHash :: Cursor -> Double
    colorHash :: (Int, Int) -> Double
colorHash (x :: Int
x, y :: Int
y) =
      let
        n :: Double
n = ((83 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (37 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)))
        unfloor :: a -> a
unfloor m :: a
m = a
m a -> a -> a
forall a. Num a => a -> a -> a
- Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor a
m)
      in Double -> Double
forall a. RealFrac a => a -> a
unfloor Double
n

    drawPiece :: MImage RealWorld VU RGB Double -> Cursor -> IO ()
    drawPiece :: MImage RealWorld VU RGB Double -> (Int, Int) -> IO ()
drawPiece image :: MImage RealWorld VU RGB Double
image (x :: Int
x, y :: Int
y) = do
      let fc :: Int
fc = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width
      Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
partId :: Int
partId :: Piece -> Int
partId, Bool
solved :: Bool
solved :: Piece -> Bool
solved} <- MMaze -> Int -> IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze Int
fc
      Double
ch <- (Int, Int) -> Double
colorHash ((Int, Int) -> Double) -> (Int -> (Int, Int)) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> (Int, Int)
mazeCursor Int
width (Int -> Double) -> IO Int -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> IO Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze Int
partId
      let cont :: Maybe Continue
cont = Int -> Continues -> Maybe Continue
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fc Continues
continues
      let colo :: Double
colo = Double -> (Continue -> Double) -> Maybe Continue -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
ch (\c :: Continue
c -> if Continue -> Int
island Continue
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 then 0.25 else 0.6) Maybe Continue
cont
      let satu :: Double
satu = if Bool
solved then 0.8 else (if Maybe Continue -> Bool
forall a. Maybe a -> Bool
isJust Maybe Continue
cont then 0.8 else 0)
      let inte :: Double
inte = if Bool
solved then 0.5 else (if Maybe Continue -> Bool
forall a. Maybe a -> Bool
isJust Maybe Continue
cont then 1 else 0.3)
      let fill :: Pixel RGB Double
fill = if Bool -> Bool
not Bool
solved Bool -> Bool -> Bool
&& Pix
pipe Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
== 0b11111111 then Double -> Double -> Double -> Pixel RGB Double
forall e. e -> e -> e -> Pixel RGB e
PixelRGB 1 1 1 else Pixel HSI Double -> Pixel RGB Double
forall cs e. ToRGB cs e => Pixel cs e -> Pixel RGB Double
toPixelRGB (Pixel HSI Double -> Pixel RGB Double)
-> Pixel HSI Double -> Pixel RGB Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Pixel HSI Double
forall e. e -> e -> e -> Pixel HSI e
PixelHSI Double
colo Double
satu Double
inte
      Int -> Pix -> Pixel RGB Double -> IO ()
write' Int
pixSize Pix
pipe Pixel RGB Double
fill

      where
        write' :: Int -> Pix -> Pixel RGB Double -> IO ()
        write' :: Int -> Pix -> Pixel RGB Double -> IO ()
write' 3 pipe :: Pix
pipe fill :: Pixel RGB Double
fill = do
          MImage (PrimState IO) VU RGB Double
-> (Int, Int) -> Pixel RGB Double -> IO ()
forall arr cs e (m :: * -> *).
(MArray arr cs e, Functor m, PrimMonad m) =>
MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m ()
write MImage RealWorld VU RGB Double
MImage (PrimState IO) VU RGB Double
image (Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixH Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Pixel RGB Double
fill
          [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Pix -> [Int]
forall p. Bits p => p -> [Int]
pixDirections Pix
pipe) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \d :: Int
d ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pix -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bit.testBit Pix
pipe Int
d) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              MImage (PrimState IO) VU RGB Double
-> (Int, Int) -> Pixel RGB Double -> IO ()
forall arr cs e (m :: * -> *).
(MArray arr cs e, Functor m, PrimMonad m) =>
MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m ()
write MImage RealWorld VU RGB Double
MImage (PrimState IO) VU RGB Double
image ((Int, Int) -> Int -> (Int, Int)
mazeDelta (Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixH Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
d) Pixel RGB Double
fill
        write' 1 _ fill :: Pixel RGB Double
fill = MImage (PrimState IO) VU RGB Double
-> (Int, Int) -> Pixel RGB Double -> IO ()
forall arr cs e (m :: * -> *).
(MArray arr cs e, Functor m, PrimMonad m) =>
MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m ()
write MImage RealWorld VU RGB Double
MImage (PrimState IO) VU RGB Double
image (Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixW, Int
border Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixH) Pixel RGB Double
fill
        write' _ _ _ = String -> IO ()
forall a. HasCallStack => String -> a
error "pixSize bad"

renderImage :: String -> MMaze -> Continues -> SolverT ()
renderImage :: String -> MMaze -> Continues -> SolverT ()
renderImage s :: String
s m :: MMaze
m c :: Continues
c = (Configuration -> Int) -> ReaderT Configuration IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Int
cPixSize ReaderT Configuration IO Int -> (Int -> SolverT ()) -> SolverT ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ps :: Int
ps -> Int -> String -> MMaze -> Continues -> SolverT ()
forall (m :: * -> *).
MonadIO m =>
Int -> String -> MMaze -> Continues -> m ()
renderImageN Int
ps String
s MMaze
m Continues
c

-- | The output format is: @images/lvl%i-%s-%0*i-%s.png level mazeId (sizeLen iter) name@
renderImage' :: String -> Progress -> SolverT Progress
renderImage' :: String -> Progress -> SolverT Progress
renderImage' name :: String
name p :: Progress
p@Progress{maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{Int
sizeLen :: Int
sizeLen :: MMaze -> Int
sizeLen}, Int
iter :: Int
iter :: Progress -> Int
iter, Continues
continues :: Continues
continues :: Progress -> Continues
continues} =
  (Progress
p Progress -> SolverT () -> SolverT Progress
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (SolverT () -> SolverT Progress)
-> (SolverT () -> SolverT ()) -> SolverT () -> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Configuration IO Bool -> SolverT () -> SolverT ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Configuration -> Bool) -> ReaderT Configuration IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bool -> Bool
not (Bool -> Bool) -> (Configuration -> Bool) -> Configuration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Bool
cBench)) (SolverT () -> SolverT Progress) -> SolverT () -> SolverT Progress
forall a b. (a -> b) -> a -> b
$ do
    String
dir <- (Configuration -> String) -> ReaderT Configuration IO String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> String
cImageDir
    String -> MMaze -> Continues -> SolverT ()
renderImage (String -> Int -> Int -> ShowS
forall r. PrintfType r => String -> r
printf (String
dir String -> ShowS
forall a. [a] -> [a] -> [a]
++ "%0*i-%s.png") Int
sizeLen Int
iter String
name) MMaze
maze Continues
continues

renderColorProgress :: MonadIO m => Maybe Continue -> Progress -> m String
renderColorProgress :: Maybe Continue -> Progress -> m String
renderColorProgress _ Progress{maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board, Int
width :: Int
width :: MMaze -> Int
width, Int
height :: Int
height :: MMaze -> Int
height}} = IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ do
  [[Piece]]
lines <- Int -> Int -> Vector Piece -> [[Piece]]
forall a. Storable a => Int -> Int -> Vector a -> [[a]]
vectorLists Int
width Int
height (Vector Piece -> [[Piece]])
-> (Vector Piece -> Vector Piece) -> Vector Piece -> [[Piece]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Piece -> Vector Piece
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
V.convert (Vector Piece -> [[Piece]]) -> IO (Vector Piece) -> IO [[Piece]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Piece -> IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState IO) Piece
board
  [String] -> String
unlines ([String] -> String)
-> ([[String]] -> [String]) -> [[String]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> String) -> IO [[String]] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Piece] -> IO [String]) -> [[Piece]] -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Piece -> IO String) -> [Piece] -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Piece -> IO String
forall (m :: * -> *). MonadIO m => Piece -> m String
fmt) [[Piece]]
lines
  where
    colorHash :: (Int, Int) -> Int
colorHash = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 70) (Int -> Int) -> ((Int, Int) -> Int) -> (Int, Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+15) (Int -> Int) -> ((Int, Int) -> Int) -> (Int, Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(x :: Int
x, y :: Int
y) -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* 67 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* 23)
    fmt :: Piece -> m String
fmt Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
partId :: Int
partId :: Piece -> Int
partId, Bool
solved :: Bool
solved :: Piece -> Bool
solved} = do
      Maybe Int
color <- (Int -> Bool) -> Maybe Int -> Maybe Int
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
solved) (Maybe Int -> Maybe Int) -> (Int -> Maybe Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
colorHash ((Int, Int) -> Int) -> (Int -> (Int, Int)) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> (Int, Int)
mazeCursor Int
width (Int -> Maybe Int) -> m Int -> m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> m Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze Int
partId
      String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case Maybe Int
color of
        Just color :: Int
color -> String -> Int -> Char -> String
forall r. PrintfType r => String -> r
printf "\x1b[38;5;%im%c\x1b[39m" ([24 :: Int, 27..231] [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
color) (Pix -> Char
toChar Pix
pipe)
        _ -> [Pix -> Char
toChar Pix
pipe]

-- | Print unicode maze with colorized ANSI escape sequences to stdout.
renderColor :: MonadIO m => MMaze -> m ()
renderColor :: MMaze -> m ()
renderColor = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (MMaze -> IO ()) -> MMaze -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()
putStrLn (String -> IO ()) -> (MMaze -> IO String) -> MMaze -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe Continue -> Progress -> IO String
forall (m :: * -> *).
MonadIO m =>
Maybe Continue -> Progress -> m String
renderColorProgress Maybe Continue
forall a. Maybe a
Nothing (Progress -> IO String)
-> (MMaze -> Progress) -> MMaze -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> Priority
-> Continues
-> Components
-> Space
-> MMaze
-> Progress
Progress 0 0 Priority
forall a. IntMap a
IntMap.empty Continues
forall a. IntMap a
IntMap.empty (Priority -> Components
Components Priority
forall a. IntMap a
IntMap.empty) [])

-- | Tracing at each @freq=@ step with @debug=@ environment variables.
--
-- Modes: 1. print stats \/ 2. print maze with terminal escape code codes \/ 3. as 2., but with clear-screen before \/
-- 4. as 1., but with image output \/ 5. as 4., but only after islands have started
traceBoard :: Continue -> Progress -> SolverT Progress
traceBoard :: Continue -> Progress -> SolverT Progress
traceBoard current :: Continue
current progress :: Progress
progress@Progress{iter :: Progress -> Int
iter=Int
iter', Int
depth :: Int
depth :: Progress -> Int
depth, maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{Int
size :: Int
size :: MMaze -> Int
size}} = do
  Configuration{Int
cDebug :: Int
cDebug :: Configuration -> Int
cDebug, Int
cDebugFreq :: Int
cDebugFreq :: Configuration -> Int
cDebugFreq} <- ReaderT Configuration IO Configuration
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
islands <-
    if Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int
cDebugFreq Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
islandSlowdown) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
    then (Continue -> Bool) -> Maybe Continue -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Int -> Bool) -> (Continue -> Int) -> Continue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continue -> Int
island) (Maybe Continue -> Bool)
-> ReaderT Configuration IO (Maybe Continue)
-> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Configuration Identity (Maybe Continue)
-> ReaderT Configuration IO (Maybe Continue)
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress -> ReaderT Configuration Identity (Maybe Continue)
findContinue Progress
progress)
    else Bool -> ReaderT Configuration IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Progress
progress Progress -> SolverT () -> SolverT Progress
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Int -> Bool -> SolverT ()
tracer Int
cDebug (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int
cDebugFreq Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (if Bool
islands then Int
islandSlowdown else 1))) Bool
islands
  where
    (iter :: Int
iter, islandSlowdown :: Int
islandSlowdown) = (Int
iter' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, 50)
    tracer :: Int -> Int -> Bool -> SolverT ()
    tracer :: Int -> Int -> Bool -> SolverT ()
tracer mode :: Int
mode freq :: Int
freq islandish :: Bool
islandish
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SolverT ()) -> IO () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
solvedStr
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SolverT ()) -> IO () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ MMaze -> IO String
renderStr MMaze
maze IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SolverT ()) -> IO () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ IO String
traceStr IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 = IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SolverT ()) -> IO () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ IO String
traceStr IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
clear String -> ShowS
forall a. [a] -> [a] -> [a]
++)
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 = Int -> Int -> Bool -> SolverT ()
tracer 0 Int
freq Bool
False SolverT () -> SolverT () -> SolverT ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SolverT Progress -> SolverT ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> Progress -> SolverT Progress
renderImage' "trace" Progress
progress)
      | Int
iter Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
freq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
mode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 5 = if Bool
islandish then Int -> Int -> Bool -> SolverT ()
tracer 4 Int
freq Bool
True else () -> SolverT ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = () -> SolverT ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    perc :: Double
perc = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size Double -> Double -> Double
forall a. Num a => a -> a -> a
* 100 :: Double
    ratio :: Double
ratio = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iter Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth :: Double
    solvedStr :: String
solvedStr = String -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf "\x1b[2Ksolved: %02.2f%%, ratio: %0.2f\x1b[1A" Double
perc Double
ratio

    clear :: String
clear = "\x1b[H\x1b[2K" -- move cursor 1,1; clear line
    traceStr :: IO String
traceStr = Maybe Continue -> Progress -> IO String
forall (m :: * -> *).
MonadIO m =>
Maybe Continue -> Progress -> m String
renderColorProgress (Continue -> Maybe Continue
forall a. a -> Maybe a
Just Continue
current) Progress
progress

{--- Model ---}

directions :: [Int]
directions = [0, 1, 2, 3]
-- | > directions = rotations = [0, 1, 2, 3]
rotations :: [Int]
rotations = [Int]
directions

charMapEntries :: [(Char, Pix)]
charMapEntries :: [(Char, Pix)]
charMapEntries = ((Char, [Int]) -> (Char, Pix)) -> [(Char, [Int])] -> [(Char, Pix)]
forall a b. (a -> b) -> [a] -> [b]
map (([Int] -> Identity Pix) -> (Char, [Int]) -> Identity (Char, Pix)
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Int] -> Identity Pix) -> (Char, [Int]) -> Identity (Char, Pix))
-> ([Int] -> Pix) -> (Char, [Int]) -> (Char, Pix)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Pix -> Pix
mirrorNibble (Pix -> Pix) -> ([Int] -> Pix) -> [Int] -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Pix
forall i. Integral i => [Int] -> i
directionsPix))
  [ ('╹', [0])
  , ('┗', [0,1])
  , ('┣', [0,1,2])
  , ('╋', [0,1,2,3])
  , ('┻', [0,1,3])
  , ('┃', [0,2])
  , ('┫', [0,2,3])
  , ('┛', [0,3])
  , ('╺', [1])
  , ('┏', [1,2])
  , ('┳', [1,2,3])
  , ('━', [1,3])
  , ('╻', [2])
  , ('┓', [2,3])
  , ('╸', [3])
  , (' ', []) -- chars outside the map
  ]
  where mirrorNibble :: Pix -> Pix
mirrorNibble = (\n :: Pix
n -> Pix
n Pix -> Pix -> Pix
forall a. Num a => a -> a -> a
+ Pix -> Int -> Pix
forall a. Bits a => a -> Int -> a
Bit.shiftL Pix
n 4) :: Pix -> Pix

charMap :: Map Char Pix
charMap :: Map Char Pix
charMap = [(Char, Pix)] -> Map Char Pix
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char, Pix)]
charMapEntries

pixMap :: Map Pix Char
pixMap :: Map Pix Char
pixMap = [(Pix, Char)] -> Map Pix Char
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Pix, Char)] -> Map Pix Char) -> [(Pix, Char)] -> Map Pix Char
forall a b. (a -> b) -> a -> b
$ ((Char, Pix) -> (Pix, Char)) -> [(Char, Pix)] -> [(Pix, Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Pix) -> (Pix, Char)
forall a b. (a, b) -> (b, a)
swap [(Char, Pix)]
charMapEntries

{-# INLINE pixRotations #-}
-- | This accounts for some piece's rotational symmetry
pixRotations :: Pix -> [Rotation]
pixRotations :: Pix -> [Int]
pixRotations 0b00000000 = [0]
pixRotations 0b11111111 = [0]
pixRotations 0b10101010 = [0, 1]
pixRotations 0b01010101 = [0, 1]
pixRotations _ = [Int]
rotations

{-# INLINE pixDirections #-}
pixDirections :: Bit.Bits p => p -> [Direction]
pixDirections :: p -> [Int]
pixDirections b :: p
b = (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\n :: Int
n -> [Int
n | p
b p -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`Bit.testBit` Int
n]) [0, 1, 2, 3]

{-# INLINE pixNDirections #-}
pixNDirections :: Bit.Bits p => p -> [Direction]
pixNDirections :: p -> [Int]
pixNDirections b :: p
b = (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\n :: Int
n -> [Int
n | Bool -> Bool
not (p
b p -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`Bit.testBit` Int
n)]) [0, 1, 2, 3]

{-# INLINE directionsPix #-}
directionsPix :: Integral i => [Direction] -> i
directionsPix :: [Int] -> i
directionsPix = Sum i -> i
forall a. Sum a -> a
getSum (Sum i -> i) -> ([Int] -> Sum i) -> [Int] -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Sum i) -> [Int] -> Sum i
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (i -> Sum i
forall a. a -> Sum a
Sum (i -> Sum i) -> (Int -> i) -> Int -> Sum i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (2 i -> Int -> i
forall a b. (Num a, Integral b) => a -> b -> a
^))

toPix :: Char -> Pix
toPix = (Map Char Pix
charMap Map Char Pix -> Char -> Pix
forall k a. Ord k => Map k a -> k -> a
!) :: Char -> Pix
toChar :: Pix -> Char
toChar = (Map Pix Char
pixMap Map Pix Char -> Pix -> Char
forall k a. Ord k => Map k a -> k -> a
!) :: Pix -> Char

{-# INLINE rotate #-}
-- | Rotates the 'Pix' to left by n 'Rotation's
rotate :: Rotation -> Pix -> Pix
rotate :: Int -> Pix -> Pix
rotate = (Pix -> Int -> Pix) -> Int -> Pix -> Pix
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pix -> Int -> Pix
forall a. Bits a => a -> Int -> a
Bit.rotateL

{--- Solver bits: per-pixel stuff ---}

-- given current pixel at rotation, does it match the pixel at direction from it?
{-# INLINE pixValid #-}
pixValid :: (Pix, Pix, Rotation, Direction) -> Bool
pixValid :: (Pix, Pix, Int, Int) -> Bool
pixValid (!Pix
this, !Pix
that, !Int
rotation, !Int
direction) =
  Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Pix -> Pix
rotate Int
rotation Pix
this Pix -> Pix -> Pix
forall a. Bits a => a -> a -> a
`Bit.xor` Int -> Pix -> Pix
rotate 2 Pix
that) Pix -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`Bit.testBit` Int
direction

{-# INLINE validateDirection #-}
validateDirection :: Pix -> Rotation -> (Piece, Direction) -> Bool
validateDirection :: Pix -> Int -> (Piece, Int) -> Bool
validateDirection this :: Pix
this rotation :: Int
rotation (Piece{pipe :: Piece -> Pix
pipe=Pix
that, Bool
solved :: Bool
solved :: Piece -> Bool
solved}, direction :: Int
direction) = do
  Bool -> Bool
not Bool
solved Bool -> Bool -> Bool
|| (Pix, Pix, Int, Int) -> Bool
pixValid (Pix
this, Pix
that, Int
rotation, Int
direction)

{-# INLINE validateRotation #-}
validateRotation :: Pix -> [(Piece, Direction)] -> Rotation -> Bool
validateRotation :: Pix -> [(Piece, Int)] -> Int -> Bool
validateRotation this :: Pix
this deltas :: [(Piece, Int)]
deltas rotation :: Int
rotation = ((Piece, Int) -> Bool) -> [(Piece, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pix -> Int -> (Piece, Int) -> Bool
validateDirection Pix
this Int
rotation) [(Piece, Int)]
deltas

{-# INLINE validateRotationM #-}
validateRotationM :: MMaze -> Cursor -> Pix -> Rotation -> IO Bool
validateRotationM :: MMaze -> (Int, Int) -> Pix -> Int -> IO Bool
validateRotationM maze :: MMaze
maze cursor :: (Int, Int)
cursor this :: Pix
this rotation :: Int
rotation =
  (((Piece, Int) -> Bool) -> IO (Piece, Int) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pix -> Int -> (Piece, Int) -> Bool
validateDirection Pix
this Int
rotation) (IO (Piece, Int) -> IO Bool)
-> (Int -> IO (Piece, Int)) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MMaze -> (Int, Int) -> Int -> IO (Piece, Int)
mazeDeltaWall MMaze
maze (Int, Int)
cursor) (Int -> IO Bool) -> [Int] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
`allM` [Int]
directions

{-# INLINE pieceChoices #-}
-- | Compute initial rotation fields for a piece's 'Choices'
pieceChoices :: MMaze -> Cursor -> IO Choices
pieceChoices :: MMaze -> (Int, Int) -> IO Int
pieceChoices maze :: MMaze
maze@MMaze{Int
width :: Int
width :: MMaze -> Int
width, Int
height :: Int
height :: MMaze -> Int
height} cur :: (Int, Int)
cur@(x :: Int
x, y :: Int
y) = do
  Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe} <- MMaze -> Int -> IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze (Int -> (Int, Int) -> Int
mazeFursor Int
width (Int, Int)
cur)
  if Bool
edge Bool -> Bool -> Bool
|| [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Pix -> [Int]
pixRotations Pix
pipe) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4
  then do
    Sum Int
valids <- (Int -> Sum Int) -> [Int] -> Sum Int
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Sum Int
forall a. (Num a, Bits a) => Int -> Sum a
choiceBits ([Int] -> Sum Int) -> IO [Int] -> IO (Sum Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO Bool) -> [Int] -> IO [Int]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (MMaze -> (Int, Int) -> Pix -> Int -> IO Bool
validateRotationM MMaze
maze (Int, Int)
cur Pix
pipe) (Pix -> [Int]
pixRotations Pix
pipe)
    Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> (Sum Int -> Int) -> Sum Int -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL Int
choicesInvalid (Int -> Int) -> (Sum Int -> Int) -> Sum Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bit.xor 0b1111 (Int -> Int) -> (Sum Int -> Int) -> Sum Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> IO Int) -> Sum Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Sum Int
valids
  else Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL 4 Int
choicesCount)
  where
    edge :: Bool
edge = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 Bool -> Bool -> Bool
|| ((Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2)
    choiceBits :: Int -> Sum a
choiceBits d :: Int
d = a -> Sum a
forall a. a -> Sum a
Sum (Int -> a
forall a. Bits a => Int -> a
Bit.bit 4 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a. Bits a => Int -> a
Bit.bit Int
d)

forceChoice :: Pix -> Pix -> Choices -> Choices
forceChoice :: Pix -> Pix -> Int -> Int
forceChoice forced :: Pix
forced pix :: Pix
pix choices :: Int
choices =
  let
    rotatation :: Int
rotatation = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust ((Int -> Bool) -> [Int] -> Maybe Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\r :: Int
r -> Int -> Pix -> Pix
rotate Int
r Pix
pix Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
== Pix
forced) [Int]
rotations)
    exceptSolveds :: Int
exceptSolveds = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL 0b1111 Int
choicesSolveds
  in
    (Int
exceptSolveds Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bit..&. Int
choices)
    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL 1 Int
choicesCount
    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL (0b1111 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`Bit.xor` Int -> Int
forall a. Bits a => Int -> a
Bit.bit Int
rotatation) Int
choicesInvalid

{-# INLINE forcePiece #-}
forcePiece :: Pix -> Piece -> Piece
forcePiece :: Pix -> Piece -> Piece
forcePiece dst :: Pix
dst p :: Piece
p@Piece{pipe :: Piece -> Pix
pipe=Pix
src} = ((Int -> Identity Int) -> Piece -> Identity Piece
Lens' Piece Int
initChoicesL ((Int -> Identity Int) -> Piece -> Identity Piece)
-> (Int -> Int) -> Piece -> Piece
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Pix -> Pix -> Int -> Int
forceChoice Pix
dst Pix
src) Piece
p

{-# INLINE forceContinue #-}
forceContinue :: Pix -> Continue -> Continue
forceContinue :: Pix -> Continue -> Continue
forceContinue dst :: Pix
dst c :: Continue
c@Continue{char :: Continue -> Pix
char=Pix
src} = ((Int -> Identity Int) -> Continue -> Identity Continue
Lens' Continue Int
choicesL ((Int -> Identity Int) -> Continue -> Identity Continue)
-> (Int -> Int) -> Continue -> Continue
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Pix -> Pix -> Int -> Int
forceChoice Pix
dst Pix
src) Continue
c

forceHints :: Continues -> Progress -> [Unwind] -> SolverT Progress
forceHints :: Continues -> Progress -> [Unwind] -> SolverT Progress
forceHints continues :: Continues
continues p :: Progress
p@Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} = (Progress -> Unwind -> SolverT Progress)
-> Progress -> [Unwind] -> SolverT Progress
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Progress -> Unwind -> SolverT Progress
deployHint Progress
p
  where
    deployHint :: Progress -> Unwind -> SolverT Progress
deployHint p :: Progress
p (UnSolve c :: Int
c _ pix :: Pix
pix) =
      if Int -> Continues -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.member Int
c Continues
continues
      then ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress
-> Int
-> (Maybe Continue -> Continue)
-> ReaderT Configuration Identity Progress
prioritizeContinue Progress
p Int
c (Pix -> Continue -> Continue
forceContinue Pix
pix (Continue -> Continue)
-> (Maybe Continue -> Continue) -> Maybe Continue -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Continue -> Continue
forall a. HasCallStack => Maybe a -> a
fromJust))
      else Progress
p Progress -> SolverT () -> SolverT Progress
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MMaze -> (Piece -> Piece) -> Int -> SolverT ()
forall (m :: * -> *).
MonadIO m =>
MMaze -> (Piece -> Piece) -> Int -> m ()
mazeModify MMaze
maze (Pix -> Piece -> Piece
forcePiece Pix
pix) Int
c
    deployHint p :: Progress
p _ = Progress -> SolverT Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
p

{--- Solver bits: components ---}

{-# INLINE compInsert #-}
compInsert :: Continue -> Components -> Components
compInsert :: Continue -> Components -> Components
compInsert Continue{Int
origin :: Int
origin :: Continue -> Int
origin} (Components c :: Priority
c) = Priority -> Components
Components ((Int -> Int -> Int) -> Int -> Int -> Priority -> Priority
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
origin 1 Priority
c)
compInsert Continue{Int
origin :: Int
origin :: Continue -> Int
origin, Int
cursor :: Int
cursor :: Continue -> Int
cursor} (Components' c :: IntMap IntSet
c) = IntMap IntSet -> Components
Components' ((IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith IntSet -> IntSet -> IntSet
IntSet.union Int
origin (Int -> IntSet
IntSet.singleton Int
cursor) IntMap IntSet
c)

{-# INLINE compRemove #-}
compRemove :: PartId -> Fursor -> Components -> Components
compRemove :: Int -> Int -> Components -> Components
compRemove origin :: Int
origin _cursor :: Int
_cursor (Components c :: Priority
c) = Priority -> Components
Components ((Int -> Maybe Int) -> Int -> Priority -> Priority
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.update (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract 1) Int
origin Priority
c)
compRemove origin :: Int
origin cursor :: Int
cursor (Components' c :: IntMap IntSet
c) = IntMap IntSet -> Components
Components' ((IntSet -> Maybe IntSet) -> Int -> IntMap IntSet -> IntMap IntSet
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.update (IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just (IntSet -> Maybe IntSet)
-> (IntSet -> IntSet) -> IntSet -> Maybe IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet -> IntSet
IntSet.delete Int
cursor) Int
origin IntMap IntSet
c)

{-# INLINE compEquate #-}
compEquate :: PartId -> [PartId] -> Components -> Components
compEquate :: Int -> [Int] -> Components -> Components
compEquate hub :: Int
hub connections :: [Int]
connections c :: Components
c = Components -> Components
equate Components
c
  where
    {-# INLINE equate #-}
    equate :: Components -> Components
equate (Components c :: Priority
c) = Priority -> Components
Components (Priority -> Components) -> Priority -> Components
forall a b. (a -> b) -> a -> b
$ (Int -> Sum Int) -> (Sum Int -> Int) -> Priority -> Priority
forall m a.
Monoid m =>
(a -> m) -> (m -> a) -> IntMap a -> IntMap a
equate' Int -> Sum Int
forall a. a -> Sum a
Sum Sum Int -> Int
forall a. Sum a -> a
getSum Priority
c
    equate (Components' c :: IntMap IntSet
c) = IntMap IntSet -> Components
Components' (IntMap IntSet -> Components) -> IntMap IntSet -> Components
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet)
-> (IntSet -> IntSet) -> IntMap IntSet -> IntMap IntSet
forall m a.
Monoid m =>
(a -> m) -> (m -> a) -> IntMap a -> IntMap a
equate' IntSet -> IntSet
forall a. a -> a
id IntSet -> IntSet
forall a. a -> a
id IntMap IntSet
c

    {-# INLINE equate' #-}
    equate' :: Monoid m => (a -> m) -> (m -> a) -> IntMap a -> IntMap a
    equate' :: (a -> m) -> (m -> a) -> IntMap a -> IntMap a
equate' lift :: a -> m
lift drop :: m -> a
drop c :: IntMap a
c = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith (\a :: a
a b :: a
b -> m -> a
drop (a -> m
lift a
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> a -> m
lift a
b)) Int
hub (m -> a
drop m
sum) IntMap a
removed
      where (sum :: m
sum, removed :: IntMap a
removed) = (Int -> (m, IntMap a) -> (m, IntMap a))
-> (m, IntMap a) -> [Int] -> (m, IntMap a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((m, IntMap a) -> Int -> (m, IntMap a))
-> Int -> (m, IntMap a) -> (m, IntMap a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> m) -> (m, IntMap a) -> Int -> (m, IntMap a)
forall t a.
Monoid t =>
(a -> t) -> (t, IntMap a) -> Int -> (t, IntMap a)
extract a -> m
lift)) (m
forall a. Monoid a => a
mempty, IntMap a
c) [Int]
connections

    {-# INLINE extract #-}
    extract :: (a -> t) -> (t, IntMap a) -> Int -> (t, IntMap a)
extract lift :: a -> t
lift (sum :: t
sum, m :: IntMap a
m) part :: Int
part = (Maybe a -> (t, Maybe a)) -> Int -> IntMap a -> (t, IntMap a)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF ((, Maybe a
forall a. Maybe a
Nothing) (t -> (t, Maybe a)) -> (Maybe a -> t) -> Maybe a -> (t, Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t -> t
forall a. Monoid a => a -> a -> a
mappend t
sum (t -> t) -> (Maybe a -> t) -> Maybe a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t) -> Maybe a -> t
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> t
lift) Int
part IntMap a
m

{-# INLINE compAlive #-}
compAlive :: PartId -> Components -> Bool
compAlive :: Int -> Components -> Bool
compAlive k :: Int
k (Components c :: Priority
c) = (Int -> Maybe Int
forall a. a -> Maybe a
Just 1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Priority -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k Priority
c
compAlive k :: Int
k (Components' c :: IntMap IntSet
c) = (Int -> Maybe Int
forall a. a -> Maybe a
Just 1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Int -> Bool)
-> (Maybe IntSet -> Maybe Int) -> Maybe IntSet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntSet -> Int) -> Maybe IntSet -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntSet -> Int
IntSet.size (Maybe IntSet -> Bool) -> Maybe IntSet -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap IntSet
c

{-# INLINE compConnected #-}
compConnected :: PartId -> Components -> [Fursor]
compConnected :: Int -> Components -> [Int]
compConnected k :: Int
k (Components' c :: IntMap IntSet
c) = (IntSet -> [Int]) -> Maybe IntSet -> [Int]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IntSet -> [Int]
IntSet.toList (Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap IntSet
c)
compConnected _ _ = []

compCounts :: Components -> IntMap Int
compCounts :: Components -> Priority
compCounts (Components c :: Priority
c) = Priority
c
compCounts (Components' c :: IntMap IntSet
c) = (IntSet -> Int) -> IntMap IntSet -> Priority
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map IntSet -> Int
IntSet.size IntMap IntSet
c

{--- Solver bits: continues ---}

{-# INLINE deltaContinue #-}
deltaContinue :: Continue -> Int -> Fursor -> Direction -> Piece -> Maybe Continue -> Continue
deltaContinue :: Continue
-> Int -> Int -> Int -> Piece -> Maybe Continue -> Continue
deltaContinue Continue{Pix
char :: Pix
char :: Continue -> Pix
char, Int
origin :: Int
origin :: Continue -> Int
origin, Int
island :: Int
island :: Continue -> Int
island, Int
area :: Int
area :: Continue -> Int
area} id :: Int
id c :: Int
c from :: Int
from Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
initChoices :: Int
initChoices :: Piece -> Int
initChoices} prev :: Maybe Continue
prev = do
  let pointed :: Bool
pointed = Pix
char Pix -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`Bit.testBit` Int
from
  let origin' :: Int
origin' = if Bool
pointed then Int
origin else Int
c
  let island' :: Int
island' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 4 (Int
island Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2) -- islands get bumped once to set area, next time to solve islands whole
  let dir :: Int
dir = (Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 4

  let initChoices' :: Int
initChoices' = Int -> (Continue -> Int) -> Maybe Continue -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
initChoices Continue -> Int
choices Maybe Continue
prev
  let validRot :: [Int]
validRot = Int -> [Int]
forall p. Bits p => p -> [Int]
pixNDirections (Int
initChoices' Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bit.shiftR` Int
choicesInvalid)
  let invalids :: [Int]
invalids = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\r :: Int
r -> Bool
pointed Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Pix -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bit.testBit (Int -> Pix -> Pix
rotate Int
r Pix
pipe) Int
dir) [Int]
validRot
  let Int
choices' :: Int = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\d :: Int
d s :: Int
s -> Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall a. Bits a => Int -> a
Bit.bit Int
choicesCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Bits a => Int -> a
Bit.bit (Int
choicesInvalid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d)) Int
initChoices' [Int]
invalids
  let solveds :: Int
solveds = Int -> Int
forall a. Bits a => Int -> a
Bit.bit (Int
dir Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
choicesSolveds)
  -- let require = fromEnum pointed `Bit.shiftL` (dir + choicesRequire) -- not used

  Int -> Pix -> Int -> Int -> Int -> Int -> Int -> Int -> Continue
Continue Int
c Pix
pipe Int
origin' 0 Int
id Int
island' Int
area (Int
choices' Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bit..|. Int
solveds)

{-# INLINE prioritizeDeltas #-}
-- | Calls 'prioritizeContinue' on nearby pieces (delta = 1)
prioritizeDeltas :: Width -> Progress -> Continue -> SolverT Progress
prioritizeDeltas :: Int -> Progress -> Continue -> SolverT Progress
prioritizeDeltas width :: Int
width p :: Progress
p@Progress{Int
iter :: Int
iter :: Progress -> Int
iter, MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} continue :: Continue
continue@Continue{cursor :: Continue -> Int
cursor=Int
cur, Int
choices :: Int
choices :: Continue -> Int
choices} = do
  (ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (ReaderT Configuration Identity Progress -> SolverT Progress)
-> ([(Int, Maybe Continue -> Continue)]
    -> ReaderT Configuration Identity Progress)
-> [(Int, Maybe Continue -> Continue)]
-> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues Progress
p) ([(Int, Maybe Continue -> Continue)] -> SolverT Progress)
-> (((Int, Int)
     -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
    -> ReaderT Configuration IO [(Int, Maybe Continue -> Continue)])
-> ((Int, Int)
    -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
-> SolverT Progress
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [(Int, Int)]
-> ((Int, Int)
    -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
-> ReaderT Configuration IO [(Int, Maybe Continue -> Continue)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] (Int -> [Int]
forall p. Bits p => p -> [Int]
pixNDirections Int
choices)) (((Int, Int)
  -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
 -> SolverT Progress)
-> ((Int, Int)
    -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
-> SolverT Progress
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i, d :: Int
d) -> do
    Piece
piece <- MMaze -> Int -> ReaderT Configuration IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze (Int -> Int -> Int -> Int
mazeFDelta Int
width Int
cur Int
d)
    let delta :: Int
delta = Int -> Int -> Int -> Int
mazeFDelta Int
width Int
cur Int
d
    (Int, Maybe Continue -> Continue)
-> ReaderT Configuration IO (Int, Maybe Continue -> Continue)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
delta, Continue
-> Int -> Int -> Int -> Piece -> Maybe Continue -> Continue
deltaContinue Continue
continue (Int
iter Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Int
delta Int
d Piece
piece)

{-# INLINE rescoreContinue #-}
-- | Recalculates the 'Continue's score, less is better (because of 'IntMap.deleteFindMin' in 'findContinue').
--
-- > score = (0 - island << 17 + (choices << (15 - choicesCount)) + x + y) << 32 + created
rescoreContinue :: Bounds -> Width -> Continue -> Continue
rescoreContinue :: Bounds -> Int -> Continue -> Continue
rescoreContinue bounds :: Bounds
bounds width :: Int
width c :: Continue
c@Continue{Int
cursor :: Int
cursor :: Continue -> Int
cursor, choices :: Continue -> Int
choices=Int
choicesBits, Int
island :: Int
island :: Continue -> Int
island, Int
area :: Int
area :: Continue -> Int
area, Int
created :: Int
created :: Continue -> Int
created} = ((Int -> Identity Int) -> Continue -> Identity Continue)
-> Int -> Continue -> Continue
forall s t a b. ASetter s t a b -> b -> s -> t
set (Int -> Identity Int) -> Continue -> Identity Continue
Lens' Continue Int
scoreL Int
score Continue
c
  where
    -- score = choices + x + y -- interesting for animations for smaller levels
    score :: Int
score = (0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bound Int -> Int -> Int
<< 34 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
island Int -> Int -> Int
<< 27 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
area Int -> Int -> Int
<< 15 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
choices Int -> Int -> Int
<< (12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
choicesCount)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) Int -> Int -> Int
<< 28 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
created
    bound :: Int
bound = if Bounds -> Int -> Bool
bounded Bounds
bounds Int
cursor then 0 else 1
    choices :: Int
choices = Int
choicesBits Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bit..&. (0b11 Int -> Int -> Int
<< Int
choicesCount)
    << :: Int -> Int -> Int
(<<) = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftL
    (x :: Int
x, y :: Int
y) = Int -> Int -> (Int, Int)
mazeCursor Int
width Int
cursor

{-# INLINE prioritizeContinue' #-}
prioritizeContinue' :: Width -> PrioCompCont -> Fursor -> (Maybe Continue -> Continue) -> Solver PrioCompCont
prioritizeContinue' :: Int
-> PrioCompCont
-> Int
-> (Maybe Continue -> Continue)
-> Solver PrioCompCont
prioritizeContinue' width :: Int
width (p :: Priority
p, cp :: Components
cp, ct :: Continues
ct) c :: Int
c get :: Maybe Continue -> Continue
get =
  (Configuration -> Identity PrioCompCont) -> Solver PrioCompCont
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Configuration -> Identity PrioCompCont) -> Solver PrioCompCont)
-> (Configuration -> Identity PrioCompCont) -> Solver PrioCompCont
forall a b. (a -> b) -> a -> b
$ \Configuration{Bounds
cBounds :: Bounds
cBounds :: Configuration -> Bounds
cBounds} -> PrioCompCont -> Identity PrioCompCont
forall a. a -> Identity a
Identity (PrioCompCont -> Identity PrioCompCont)
-> PrioCompCont -> Identity PrioCompCont
forall a b. (a -> b) -> a -> b
$ Bounds -> Maybe Continue -> PrioCompCont
found Bounds
cBounds (Int -> Continues -> Maybe Continue
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
c Continues
ct)
  where
    found :: Bounds -> Maybe Continue -> PrioCompCont
    found :: Bounds -> Maybe Continue -> PrioCompCont
found bounds :: Bounds
bounds Nothing =
      let new :: Continue
new = Bounds -> Int -> Continue -> Continue
rescoreContinue Bounds
bounds Int
width (Maybe Continue -> Continue
get Maybe Continue
forall a. Maybe a
Nothing)
      in (Int -> Int -> Priority -> Priority
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (Continue -> Int
score Continue
new) Int
c Priority
p, Continue -> Components -> Components
compInsert Continue
new Components
cp, Int -> Continue -> Continues -> Continues
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
c Continue
new Continues
ct)
    found bounds :: Bounds
bounds (Just old :: Continue
old@Continue{Int
cursor :: Int
cursor :: Continue -> Int
cursor, Int
created :: Int
created :: Continue -> Int
created, choices :: Continue -> Int
choices=Int
choicesO}) =
      if Continue -> Int
score Continue
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Continue -> Int
score Continue
old Bool -> Bool -> Bool
|| Int
choicesN Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
choicesO
      then (Int -> Int -> Priority -> Priority
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (Continue -> Int
score Continue
new) Int
cursor (Priority -> Priority)
-> (Priority -> Priority) -> Priority -> Priority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Priority -> Priority
forall a. Int -> IntMap a -> IntMap a
IntMap.delete (Continue -> Int
score Continue
old) (Priority -> Priority) -> Priority -> Priority
forall a b. (a -> b) -> a -> b
$ Priority
p, Components
cp, Int -> Continue -> Continues -> Continues
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
c Continue
new Continues
ct)
      else (Priority
p, Components
cp, Continues
ct)
      where new :: Continue
new@Continue{choices :: Continue -> Int
choices=Int
choicesN} = Bounds -> Int -> Continue -> Continue
rescoreContinue Bounds
bounds Int
width (Maybe Continue -> Continue
get (Continue -> Maybe Continue
forall a. a -> Maybe a
Just Continue
old)) { Int
created :: Int
created :: Int
created }

{-# INLINE prioritizeContinues #-}
-- | Inserts or reprioritizes 'Continue'
prioritizeContinues :: Progress -> [(Fursor, Maybe Continue -> Continue)] -> Solver Progress
prioritizeContinues :: Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues progress :: Progress
progress@Progress{maze :: Progress -> MMaze
maze=MMaze{Int
width :: Int
width :: MMaze -> Int
width}, Priority
priority :: Priority
priority :: Progress -> Priority
priority, Continues
continues :: Continues
continues :: Progress -> Continues
continues, Components
components :: Components
components :: Progress -> Components
components} reprios :: [(Int, Maybe Continue -> Continue)]
reprios =
  PrioCompCont -> Progress
putback (PrioCompCont -> Progress)
-> Solver PrioCompCont -> ReaderT Configuration Identity Progress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrioCompCont
 -> (Int, Maybe Continue -> Continue) -> Solver PrioCompCont)
-> PrioCompCont
-> [(Int, Maybe Continue -> Continue)]
-> Solver PrioCompCont
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM PrioCompCont
-> (Int, Maybe Continue -> Continue) -> Solver PrioCompCont
prio (Priority
priority, Components
components, Continues
continues) [(Int, Maybe Continue -> Continue)]
reprios
  where
    putback :: PrioCompCont -> Progress
putback (p :: Priority
p, cp :: Components
cp, cn :: Continues
cn) = Progress
progress { priority :: Priority
priority = Priority
p, components :: Components
components = Components
cp, continues :: Continues
continues = Continues
cn }
    prio :: PrioCompCont
-> (Int, Maybe Continue -> Continue) -> Solver PrioCompCont
prio acc :: PrioCompCont
acc (c :: Int
c, get :: Maybe Continue -> Continue
get) = Int
-> PrioCompCont
-> Int
-> (Maybe Continue -> Continue)
-> Solver PrioCompCont
prioritizeContinue' Int
width PrioCompCont
acc Int
c Maybe Continue -> Continue
get

{-# INLINE prioritizeContinue #-}
prioritizeContinue :: Progress -> Fursor -> (Maybe Continue -> Continue) -> Solver Progress
prioritizeContinue :: Progress
-> Int
-> (Maybe Continue -> Continue)
-> ReaderT Configuration Identity Progress
prioritizeContinue p :: Progress
p = ((Int, Maybe Continue -> Continue)
 -> ReaderT Configuration Identity Progress)
-> Int
-> (Maybe Continue -> Continue)
-> ReaderT Configuration Identity Progress
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues Progress
p ([(Int, Maybe Continue -> Continue)]
 -> ReaderT Configuration Identity Progress)
-> ((Int, Maybe Continue -> Continue)
    -> [(Int, Maybe Continue -> Continue)])
-> (Int, Maybe Continue -> Continue)
-> ReaderT Configuration Identity Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Continue -> Continue)
-> [(Int, Maybe Continue -> Continue)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

{-# INLINE pieceDead #-}
-- | Check if 'Continue' is about to become separated from the rest of the graph.
pieceDead :: MonadIO m => MMaze -> Components -> Fursor -> Pix -> Choices -> m Bool
pieceDead :: MMaze -> Components -> Int -> Pix -> Int -> m Bool
pieceDead _ _ _ 0b00000000 _ = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
pieceDead maze :: MMaze
maze components :: Components
components cur :: Int
cur pix :: Pix
pix choices :: Int
choices = do
  Int
thisPart <- MMaze -> Int -> m Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze (Int -> m Int) -> (Piece -> Int) -> Piece -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Int
partId (Piece -> m Int) -> m Piece -> m Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> Int -> m Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze Int
cur
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Components -> Bool
compAlive Int
thisPart Components
components Bool -> Bool -> Bool
&& Bool
stuck)
  where stuck :: Bool
stuck = 0 Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
== ((0b1111 Pix -> Pix -> Pix
forall a. Bits a => a -> a -> a
Bit..&. Pix
pix) Pix -> Pix -> Pix
forall a. Bits a => a -> a -> a
Bit..&. Pix -> Pix
forall a. Bits a => a -> a
Bit.complement (Int -> Pix
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
choices))

-- | Pops `priority` by `score`, deletes from `continues`.
{-# INLINE findContinue #-}
findContinue :: Progress -> Solver (Maybe Continue)
findContinue :: Progress -> ReaderT Configuration Identity (Maybe Continue)
findContinue Progress{Priority
priority :: Priority
priority :: Progress -> Priority
priority, Continues
continues :: Continues
continues :: Progress -> Continues
continues} = do
  (Configuration -> Identity (Maybe Continue))
-> ReaderT Configuration Identity (Maybe Continue)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Configuration -> Identity (Maybe Continue))
 -> ReaderT Configuration Identity (Maybe Continue))
-> (Configuration -> Identity (Maybe Continue))
-> ReaderT Configuration Identity (Maybe Continue)
forall a b. (a -> b) -> a -> b
$ \Configuration{SolveMode
cMode :: SolveMode
cMode :: Configuration -> SolveMode
cMode, Bounds
cBounds :: Bounds
cBounds :: Configuration -> Bounds
cBounds} -> Maybe Continue -> Identity (Maybe Continue)
forall a. a -> Identity a
Identity (Maybe Continue -> Identity (Maybe Continue))
-> Maybe Continue -> Identity (Maybe Continue)
forall a b. (a -> b) -> a -> b
$ do
    Int
cursor <- (Int -> Bool) -> Maybe Int -> Maybe Int
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bounds -> Int -> Bool
bounded Bounds
cBounds) ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Priority -> Maybe (Int, Int)
forall a. IntMap a -> Maybe (Int, a)
IntMap.lookupMin Priority
priority)
    (Continue -> Bool) -> Maybe Continue -> Maybe Continue
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter
      (\Continue{Int
choices :: Int
choices :: Continue -> Int
choices} -> SolveMode -> Bool
solveDeterministic SolveMode
cMode Bool -> Bool -> Bool
|| (2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftR Int
choices Int
choicesCount))
      (Int
cursor Int -> Continues -> Maybe Continue
forall a. Int -> IntMap a -> Maybe a
`IntMap.lookup` Continues
continues)

{-# INLINE popContinue #-}
-- | Pops next 'Continue' from queue.
popContinue :: Progress -> Progress
popContinue :: Progress -> Progress
popContinue p :: Progress
p@Progress{priority :: Progress -> Priority
priority=Priority
pr, continues :: Progress -> Continues
continues=Continues
c} = Progress
p { Priority
priority :: Priority
priority :: Priority
priority, continues :: Continues
continues = Int -> Continues -> Continues
forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
cursor Continues
c }
  where ((_, cursor :: Int
cursor), priority :: Priority
priority) = Priority -> ((Int, Int), Priority)
forall a. IntMap a -> ((Int, a), IntMap a)
IntMap.deleteFindMin Priority
pr

{--- Backtracking solver ---}

-- | Solves a valid piece, mutates the maze and sets unwind.
-- Inefficient access: partEquate reads the same data as islands reads.
-- (All functions within this function are inlined)
solveContinue :: Progress -> Continue -> SolverT Progress
solveContinue :: Progress -> Continue -> SolverT Progress
solveContinue
  progress :: Progress
progress@Progress{maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{Int
width :: Int
width :: MMaze -> Int
width}, components :: Progress -> Components
components = Components
components_}
  continue :: Continue
continue@Continue{Int
cursor :: Int
cursor :: Continue -> Int
cursor, Pix
char :: Pix
char :: Continue -> Pix
char, origin :: Continue -> Int
origin = Int
origin_} = do
    Int
thisPart <- MMaze -> Int -> ReaderT Configuration IO Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze Int
origin_
    Unwind
unwindThis <- MMaze -> Continue -> ReaderT Configuration IO Unwind
forall (m :: * -> *). MonadIO m => MMaze -> Continue -> m Unwind
mazeSolve MMaze
maze Continue
continue
    let directDeltas :: [Int]
directDeltas = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int -> Int
mazeFDelta Int
width Int
cursor) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Pix -> [Int]
forall p. Bits p => p -> [Int]
pixDirections Pix
char
    [Int]
neighbours <- ([Int] -> [Int])
-> ReaderT Configuration IO [Int] -> ReaderT Configuration IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubOrd ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
thisPart Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:)) (ReaderT Configuration IO [Int] -> ReaderT Configuration IO [Int])
-> ([Int] -> ReaderT Configuration IO [Int])
-> [Int]
-> ReaderT Configuration IO [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ReaderT Configuration IO Int)
-> [Int] -> ReaderT Configuration IO [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (MMaze -> Int -> ReaderT Configuration IO Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze) ([Int] -> ReaderT Configuration IO [Int])
-> [Int] -> ReaderT Configuration IO [Int]
forall a b. (a -> b) -> a -> b
$ [Int]
directDeltas
    let origin :: Int
origin = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
neighbours
    let components :: Components
components = Int -> [Int] -> Components -> Components
compEquate Int
origin ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
origin) [Int]
neighbours) (Int -> Int -> Components -> Components
compRemove Int
thisPart Int
cursor Components
components_)
    [Unwind]
unwindEquate <- MMaze -> Int -> [Int] -> ReaderT Configuration IO [Unwind]
forall (m :: * -> *).
MonadIO m =>
MMaze -> Int -> [Int] -> m [Unwind]
mazeEquate MMaze
maze Int
origin [Int]
neighbours

    Continue -> Progress -> SolverT Progress
traceBoard Continue
continue (Progress -> SolverT Progress)
-> (Progress -> Progress) -> Progress -> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Identity Int) -> Progress -> Identity Progress
Lens' Progress Int
iterL ((Int -> Identity Int) -> Progress -> Identity Progress)
-> (Int -> Int) -> Progress -> Progress
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)) (Progress -> Progress)
-> (Progress -> Progress) -> Progress -> Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Identity Int) -> Progress -> Identity Progress
Lens' Progress Int
depthL ((Int -> Identity Int) -> Progress -> Identity Progress)
-> (Int -> Int) -> Progress -> Progress
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1))
      (Progress -> Progress)
-> (Progress -> Progress) -> Progress -> Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Space -> Identity Space) -> Progress -> Identity Progress
Lens' Progress Space
spaceL ((Space -> Identity Space) -> Progress -> Identity Progress)
-> ((([(Continue, Progress)], [Unwind])
     -> Identity ([(Continue, Progress)], [Unwind]))
    -> Space -> Identity Space)
-> (([(Continue, Progress)], [Unwind])
    -> Identity ([(Continue, Progress)], [Unwind]))
-> Progress
-> Identity Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(Continue, Progress)], [Unwind])
 -> Identity ([(Continue, Progress)], [Unwind]))
-> Space -> Identity Space
forall s a. Cons s s a a => Traversal' s a
_head ((([(Continue, Progress)], [Unwind])
  -> Identity ([(Continue, Progress)], [Unwind]))
 -> Progress -> Identity Progress)
-> (([(Continue, Progress)], [Unwind])
    -> ([(Continue, Progress)], [Unwind]))
-> Progress
-> Progress
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (, Unwind
unwindThis Unwind -> [Unwind] -> [Unwind]
forall a. a -> [a] -> [a]
: [Unwind]
unwindEquate) ([(Continue, Progress)] -> ([(Continue, Progress)], [Unwind]))
-> (([(Continue, Progress)], [Unwind]) -> [(Continue, Progress)])
-> ([(Continue, Progress)], [Unwind])
-> ([(Continue, Progress)], [Unwind])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Continue, Progress)], [Unwind]) -> [(Continue, Progress)]
forall a b. (a, b) -> a
fst)
      (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Progress -> Continue -> SolverT Progress
prioritizeDeltas Int
width Progress
progress { Components
components :: Components
components :: Components
components } Continue
continue { Int
origin :: Int
origin :: Int
origin }

-- | The initial 'Progress', 'space' stack, 'Progress' and 'MMaze' backtracking operations.
-- This returns a progress with the first available 'Continue' from 'space' or Nothing.
-- If 'space' is empty, it gets popped, 'mazePop' gets called and it tries again until 'space' is empty.
backtrack :: MonadIO m => Progress -> m (Maybe (Progress, Continue))
backtrack :: Progress -> m (Maybe (Progress, Continue))
backtrack Progress{space :: Progress -> Space
space=[]} = Maybe (Progress, Continue) -> m (Maybe (Progress, Continue))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Progress, Continue)
forall a. Maybe a
Nothing
backtrack p :: Progress
p@Progress{space :: Progress -> Space
space=(([], []):space :: Space
space)} =
  Progress -> m (Maybe (Progress, Continue))
forall (m :: * -> *).
MonadIO m =>
Progress -> m (Maybe (Progress, Continue))
backtrack Progress
p { Space
space :: Space
space :: Space
space }
backtrack Progress{space :: Progress -> Space
space=(((continue :: Continue
continue, p :: Progress
p):guesses :: [(Continue, Progress)]
guesses, []):space :: Space
space), MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze, Int
iter :: Int
iter :: Progress -> Int
iter} = do
  Maybe (Progress, Continue) -> m (Maybe (Progress, Continue))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Progress, Continue) -> Maybe (Progress, Continue)
forall a. a -> Maybe a
Just (Progress
p { MMaze
maze :: MMaze
maze :: MMaze
maze, Int
iter :: Int
iter :: Int
iter, space :: Space
space = ([(Continue, Progress)]
guesses, []) ([(Continue, Progress)], [Unwind]) -> Space -> Space
forall a. a -> [a] -> [a]
: Space
space }, Continue
continue))
backtrack p :: Progress
p@Progress{space :: Progress -> Space
space=((guesses :: [(Continue, Progress)]
guesses, unwind :: [Unwind]
unwind):space :: Space
space), MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} = do
  (Unwind -> m ()) -> [Unwind] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MMaze -> Unwind -> m ()
forall (m :: * -> *). MonadIO m => MMaze -> Unwind -> m ()
mazePop MMaze
maze) [Unwind]
unwind
  Progress -> m (Maybe (Progress, Continue))
forall (m :: * -> *).
MonadIO m =>
Progress -> m (Maybe (Progress, Continue))
backtrack Progress
p { space :: Space
space = ([(Continue, Progress)]
guesses, []) ([(Continue, Progress)], [Unwind]) -> Space -> Space
forall a. a -> [a] -> [a]
: Space
space }

-- | Solves pieces by backtracking, stops when the maze is solved or constraints met.
solve' :: Progress -> SolverT (Maybe Progress)
solve' :: Progress -> SolverT (Maybe Progress)
solve' p :: Progress
p@Progress{Int
depth :: Int
depth :: Progress -> Int
depth, maze :: Progress -> MMaze
maze=MMaze{Int
size :: Int
size :: MMaze -> Int
size}} | Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size = Maybe Progress -> SolverT (Maybe Progress)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progress -> Maybe Progress
forall a. a -> Maybe a
Just Progress
p) -- remove this to compute all solutions
solve' progress :: Progress
progress@Progress{Int
depth :: Int
depth :: Progress -> Int
depth, maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{Int
size :: Int
size :: MMaze -> Int
size}, Components
components :: Components
components :: Progress -> Components
components} = do
  Configuration{Int
cLifespan :: Int
cLifespan :: Configuration -> Int
cLifespan, SolveMode
cMode :: SolveMode
cMode :: Configuration -> SolveMode
cMode} <- ReaderT Configuration IO Configuration
forall r (m :: * -> *). MonadReader r m => m r
ask
  [(Continue, Progress)]
guesses <- IO [(Continue, Progress)]
-> ReaderT Configuration IO [(Continue, Progress)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Continue, Progress)]
 -> ReaderT Configuration IO [(Continue, Progress)])
-> (Maybe Continue -> IO [(Continue, Progress)])
-> Maybe Continue
-> ReaderT Configuration IO [(Continue, Progress)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Continue -> IO [(Continue, Progress)])
-> [Continue] -> IO [(Continue, Progress)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Progress -> Continue -> IO [(Continue, Progress)]
forall (m :: * -> *).
MonadIO m =>
Progress -> Continue -> m [(Continue, Progress)]
guesses Progress
progress) ([Continue] -> IO [(Continue, Progress)])
-> (Maybe Continue -> [Continue])
-> Maybe Continue
-> IO [(Continue, Progress)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Continue -> [Continue]
forall a. Maybe a -> [a]
maybeToList (Maybe Continue -> ReaderT Configuration IO [(Continue, Progress)])
-> ReaderT Configuration IO (Maybe Continue)
-> ReaderT Configuration IO [(Continue, Progress)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Configuration Identity (Maybe Continue)
-> ReaderT Configuration IO (Maybe Continue)
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress -> ReaderT Configuration Identity (Maybe Continue)
findContinue Progress
progress)
  Maybe (Progress, Continue)
guess <- Progress -> ReaderT Configuration IO (Maybe (Progress, Continue))
forall (m :: * -> *).
MonadIO m =>
Progress -> m (Maybe (Progress, Continue))
backtrack (Progress -> ReaderT Configuration IO (Maybe (Progress, Continue)))
-> (Progress -> Progress)
-> Progress
-> ReaderT Configuration IO (Maybe (Progress, Continue))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Space -> Identity Space) -> Progress -> Identity Progress
Lens' Progress Space
spaceL ((Space -> Identity Space) -> Progress -> Identity Progress)
-> (Space -> Space) -> Progress -> Progress
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ if [(Continue, Progress)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Continue, Progress)]
guesses then Space -> Space
forall a. a -> a
id else (([(Continue, Progress)]
guesses, []) ([(Continue, Progress)], [Unwind]) -> Space -> Space
forall a. a -> [a] -> [a]
:)) (Progress -> ReaderT Configuration IO (Maybe (Progress, Continue)))
-> SolverT Progress
-> ReaderT Configuration IO (Maybe (Progress, Continue))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Progress -> SolverT Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
progress
  Maybe (Progress, Continue)
guess <- Maybe (Progress, Continue)
-> ReaderT Configuration IO (Maybe (Progress, Continue))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Progress, Continue)
 -> ReaderT Configuration IO (Maybe (Progress, Continue)))
-> Maybe (Progress, Continue)
-> ReaderT Configuration IO (Maybe (Progress, Continue))
forall a b. (a -> b) -> a -> b
$ Maybe (Progress, Continue)
guess Maybe (Progress, Continue)
-> (Maybe (Progress, Continue) -> Maybe (Progress, Continue))
-> Maybe (Progress, Continue)
forall a b. a -> (a -> b) -> b
& ((Progress, Continue) -> Identity (Progress, Continue))
-> Maybe (Progress, Continue)
-> Identity (Maybe (Progress, Continue))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((Progress, Continue) -> Identity (Progress, Continue))
 -> Maybe (Progress, Continue)
 -> Identity (Maybe (Progress, Continue)))
-> ((Space -> Identity Space)
    -> (Progress, Continue) -> Identity (Progress, Continue))
-> (Space -> Identity Space)
-> Maybe (Progress, Continue)
-> Identity (Maybe (Progress, Continue))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Progress -> Identity Progress)
-> (Progress, Continue) -> Identity (Progress, Continue)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Progress -> Identity Progress)
 -> (Progress, Continue) -> Identity (Progress, Continue))
-> ((Space -> Identity Space) -> Progress -> Identity Progress)
-> (Space -> Identity Space)
-> (Progress, Continue)
-> Identity (Progress, Continue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Space -> Identity Space) -> Progress -> Identity Progress
Lens' Progress Space
spaceL ((Space -> Identity Space)
 -> Maybe (Progress, Continue)
 -> Identity (Maybe (Progress, Continue)))
-> (Space -> Space)
-> Maybe (Progress, Continue)
-> Maybe (Progress, Continue)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (if SolveMode -> Bool
solveWithHistory SolveMode
cMode then Space -> Space
forall a. a -> a
id else Space -> Space
forall a. [a] -> [a]
init)
  Maybe Progress
progress <- ((Progress, Continue) -> SolverT Progress)
-> Maybe (Progress, Continue) -> SolverT (Maybe Progress)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Progress -> Continue -> SolverT Progress)
-> (Progress, Continue) -> SolverT Progress
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Progress -> Continue -> SolverT Progress
solveContinue (Progress -> Continue -> SolverT Progress)
-> (Progress -> Progress)
-> Progress
-> Continue
-> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress -> Progress
popContinue)) Maybe (Progress, Continue)
guess

  Bool
unbounded <- Maybe Continue -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe Continue -> Bool)
-> (Maybe (Maybe Continue) -> Maybe Continue)
-> Maybe (Maybe Continue)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe Continue) -> Maybe Continue
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Continue) -> Bool)
-> ReaderT Configuration IO (Maybe (Maybe Continue))
-> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Configuration Identity (Maybe (Maybe Continue))
-> ReaderT Configuration IO (Maybe (Maybe Continue))
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT ((Progress -> ReaderT Configuration Identity (Maybe Continue))
-> Maybe Progress
-> ReaderT Configuration Identity (Maybe (Maybe Continue))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Progress -> ReaderT Configuration Identity (Maybe Continue)
findContinue Maybe Progress
progress)
  let stop :: Bool
stop = Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Bool -> Bool -> Bool
|| Int
cLifespan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Bool
unbounded
  (Configuration -> Configuration)
-> SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT ((Int -> Identity Int) -> Configuration -> Identity Configuration
Lens' Configuration Int
cLifespanL ((Int -> Identity Int) -> Configuration -> Identity Configuration)
-> (Int -> Int) -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract 1) (SolverT (Maybe Progress) -> SolverT (Maybe Progress))
-> SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Progress -> SolverT (Maybe Progress)
next Bool
stop Maybe Progress
progress
  where
    next :: Bool -> Maybe Progress -> SolverT (Maybe Progress)
next True = Maybe Progress -> SolverT (Maybe Progress)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    next False = (Maybe (Maybe Progress) -> Maybe Progress)
-> ReaderT Configuration IO (Maybe (Maybe Progress))
-> SolverT (Maybe Progress)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe Progress) -> Maybe Progress
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ReaderT Configuration IO (Maybe (Maybe Progress))
 -> SolverT (Maybe Progress))
-> (Maybe Progress
    -> ReaderT Configuration IO (Maybe (Maybe Progress)))
-> Maybe Progress
-> SolverT (Maybe Progress)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Progress -> SolverT (Maybe Progress))
-> Maybe Progress
-> ReaderT Configuration IO (Maybe (Maybe Progress))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Progress -> SolverT (Maybe Progress)
solve'

    guesses :: MonadIO m => Progress -> Continue -> m [(Continue, Progress)]
    guesses :: Progress -> Continue -> m [(Continue, Progress)]
guesses progress :: Progress
progress continue :: Continue
continue@Continue{Int
cursor :: Int
cursor :: Continue -> Int
cursor, Pix
char :: Pix
char :: Continue -> Pix
char, Int
choices :: Int
choices :: Continue -> Int
choices} = do
      let rotations :: [Int]
rotations = Int -> [Int]
forall p. Bits p => p -> [Int]
pixNDirections (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bit.shiftR Int
choices Int
choicesInvalid)
      [(Int, Pix, Int)]
rotations <- [(Int, Pix, Int)] -> m [(Int, Pix, Int)]
forall (m :: * -> *).
MonadIO m =>
[(Int, Pix, Int)] -> m [(Int, Pix, Int)]
filterDisconnected ((Int -> (Int, Pix, Int)) -> [Int] -> [(Int, Pix, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\r :: Int
r -> (Int
cursor, Int -> Pix -> Pix
rotate Int
r Pix
char, Int
choices)) [Int]
rotations)
      [(Continue, Progress)] -> m [(Continue, Progress)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int, Pix, Int) -> (Continue, Progress))
-> [(Int, Pix, Int)] -> [(Continue, Progress)]
forall a b. (a -> b) -> [a] -> [b]
map (\(_, pipe :: Pix
pipe, _) -> (ASetter Continue Continue Pix Pix -> Pix -> Continue -> Continue
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Continue Continue Pix Pix
Lens' Continue Pix
charL Pix
pipe Continue
continue, Progress
progress)) [(Int, Pix, Int)]
rotations)

    filterDisconnected :: MonadIO m => [(Fursor, Pix, Choices)] -> m [(Fursor, Pix, Choices)]
    filterDisconnected :: [(Int, Pix, Int)] -> m [(Int, Pix, Int)]
filterDisconnected = ((Int, Pix, Int) -> m Bool)
-> [(Int, Pix, Int)] -> m [(Int, Pix, Int)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (((Int, Pix, Int) -> m Bool)
 -> [(Int, Pix, Int)] -> m [(Int, Pix, Int)])
-> ((Int, Pix, Int) -> m Bool)
-> [(Int, Pix, Int)]
-> m [(Int, Pix, Int)]
forall a b. (a -> b) -> a -> b
$ \(cur :: Int
cur, pix :: Pix
pix, choices :: Int
choices) -> do
      Bool
disconnected <- MMaze -> Components -> Int -> Pix -> Int -> m Bool
forall (m :: * -> *).
MonadIO m =>
MMaze -> Components -> Int -> Pix -> Int -> m Bool
pieceDead MMaze
maze Components
components Int
cur Pix
pix Int
choices
      Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
disconnected)

{--- Island computations ---}

-- | The generic /paint/ of the 'flood' fill.
type FillNext m s = MMaze -> Cursor -> Piece -> [(Piece, Direction)] -> StateT s m [Cursor]

-- | Four-way flood fill with 'FillNext' as the "paint". The initial piece is assumed to be valid FillNext.
flood :: MonadIO m => Monoid s => FillNext m s -> MMaze -> Cursor -> m (Set Cursor, s)
flood :: FillNext m s -> MMaze -> (Int, Int) -> m (Set (Int, Int), s)
flood n :: FillNext m s
n m :: MMaze
m = (StateT s m (Set (Int, Int)) -> s -> m (Set (Int, Int), s))
-> s -> StateT s m (Set (Int, Int)) -> m (Set (Int, Int), s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT s m (Set (Int, Int)) -> s -> m (Set (Int, Int), s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT s
forall a. Monoid a => a
mempty (StateT s m (Set (Int, Int)) -> m (Set (Int, Int), s))
-> ((Int, Int) -> StateT s m (Set (Int, Int)))
-> (Int, Int)
-> m (Set (Int, Int), s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillNext m s
-> MMaze
-> Set (Int, Int)
-> [(Int, Int)]
-> StateT s m (Set (Int, Int))
forall (m :: * -> *) s.
MonadIO m =>
FillNext m s
-> MMaze
-> Set (Int, Int)
-> [(Int, Int)]
-> StateT s m (Set (Int, Int))
flood' FillNext m s
n MMaze
m Set (Int, Int)
forall a. Set a
Set.empty ([(Int, Int)] -> StateT s m (Set (Int, Int)))
-> ((Int, Int) -> [(Int, Int)])
-> (Int, Int)
-> StateT s m (Set (Int, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> [(Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return
  where
  flood' :: MonadIO m => FillNext m s -> MMaze -> Set Cursor -> [Cursor] -> StateT s m (Set Cursor)
  flood' :: FillNext m s
-> MMaze
-> Set (Int, Int)
-> [(Int, Int)]
-> StateT s m (Set (Int, Int))
flood' _ _ visited :: Set (Int, Int)
visited [] = Set (Int, Int) -> StateT s m (Set (Int, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set (Int, Int)
visited
  flood' fillNext :: FillNext m s
fillNext maze :: MMaze
maze@MMaze{width :: MMaze -> Int
width=Int
w} visited :: Set (Int, Int)
visited (cursor :: (Int, Int)
cursor@(x :: Int
x, y :: Int
y):next :: [(Int, Int)]
next) = do
    Piece
this <- IO Piece -> StateT s m Piece
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MMaze -> Int -> IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w))
    [(Int, Int)]
more <- FillNext m s
fillNext MMaze
maze (Int, Int)
cursor Piece
this ([(Piece, Int)] -> StateT s m [(Int, Int)])
-> StateT s m [(Piece, Int)] -> StateT s m [(Int, Int)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [(Piece, Int)] -> StateT s m [(Piece, Int)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MMaze -> (Int, Int) -> IO [(Piece, Int)]
mazeDeltasWalls MMaze
maze (Int, Int)
cursor)
    let next' :: [(Int, Int)]
next' = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Int, Int) -> Bool) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> Set (Int, Int) -> Bool)
-> Set (Int, Int) -> (Int, Int) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set (Int, Int)
visited) [(Int, Int)]
more [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
next
    FillNext m s
-> MMaze
-> Set (Int, Int)
-> [(Int, Int)]
-> StateT s m (Set (Int, Int))
forall (m :: * -> *) s.
MonadIO m =>
FillNext m s
-> MMaze
-> Set (Int, Int)
-> [(Int, Int)]
-> StateT s m (Set (Int, Int))
flood' FillNext m s
fillNext MMaze
maze ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Int, Int)
cursor Set (Int, Int)
visited) [(Int, Int)]
next'

-- | Set low priority to all continues with island = 1.
islandize :: Progress -> SolverT Progress
islandize :: Progress -> SolverT Progress
islandize p :: Progress
p@Progress{Continues
continues :: Continues
continues :: Progress -> Continues
continues} = ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (ReaderT Configuration Identity Progress -> SolverT Progress)
-> ReaderT Configuration Identity Progress -> SolverT Progress
forall a b. (a -> b) -> a -> b
$ do
  Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues Progress
p ((Int -> (Int, Maybe Continue -> Continue))
-> [Int] -> [(Int, Maybe Continue -> Continue)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe Continue -> Continue
mapContinue) (IntSet -> [Int]
IntSet.toList (Continues -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet Continues
continues)))
  where mapContinue :: Maybe Continue -> Continue
mapContinue = ((Int -> Identity Int) -> Continue -> Identity Continue)
-> Int -> Continue -> Continue
forall s t a b. ASetter s t a b -> b -> s -> t
set (Int -> Identity Int) -> Continue -> Identity Continue
Lens' Continue Int
areaL 999 (Continue -> Continue)
-> (Maybe Continue -> Continue) -> Maybe Continue -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Identity Int) -> Continue -> Identity Continue)
-> Int -> Continue -> Continue
forall s t a b. ASetter s t a b -> b -> s -> t
set (Int -> Identity Int) -> Continue -> Identity Continue
Lens' Continue Int
islandL 1 (Continue -> Continue)
-> (Maybe Continue -> Continue) -> Maybe Continue -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Continue -> Continue
forall a. HasCallStack => Maybe a -> a
fromJust

islandConnectivityRefinement :: [IslandSolution] -> [IslandSolution]
islandConnectivityRefinement :: [IslandSolution] -> [IslandSolution]
islandConnectivityRefinement = POSet IslandSolution -> [IslandSolution]
forall k. PartialOrd k => POSet k -> [k]
POSet.lookupMax (POSet IslandSolution -> [IslandSolution])
-> ([IslandSolution] -> POSet IslandSolution)
-> [IslandSolution]
-> [IslandSolution]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IslandSolution] -> POSet IslandSolution
forall k. PartialOrd k => [k] -> POSet k
POSet.fromList ([IslandSolution] -> POSet IslandSolution)
-> ([IslandSolution] -> [IslandSolution])
-> [IslandSolution]
-> POSet IslandSolution
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([IslandSolution] -> IslandSolution)
-> [[IslandSolution]] -> [IslandSolution]
forall a b. (a -> b) -> [a] -> [b]
map [IslandSolution] -> IslandSolution
forall a. [a] -> a
head ([[IslandSolution]] -> [IslandSolution])
-> ([IslandSolution] -> [[IslandSolution]])
-> [IslandSolution]
-> [IslandSolution]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IslandSolution -> Priority)
-> [IslandSolution] -> [[IslandSolution]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupSortOn IslandSolution -> Priority
icComponents

{- HLINT ignore islandChoices "Redundant bang pattern" -}
-- | Computes and set 'iChoices'/'iSolutions' for the island, but also modifies maze with 'icHints' if len choices == 1.
islandChoices :: MMaze -> Progress -> Island -> SolverT Island
islandChoices :: MMaze -> Progress -> Island -> SolverT Island
islandChoices _ Progress{components :: Progress -> Components
components=Components _} _ = String -> SolverT Island
forall a. HasCallStack => String -> a
error "not enough info, unlikely"
islandChoices maze' :: MMaze
maze' p :: Progress
p@Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze, components :: Progress -> Components
components=Components' compInit :: IntMap IntSet
compInit} i :: Island
i@Island{IntSet
iBounds :: IntSet
iBounds :: Island -> IntSet
iBounds} = do
  !(capped :: Bool
capped, solutions :: [(Progress, [IslandSolution])]
solutions) <- Int
-> ((Progress, [IslandSolution])
    -> ReaderT Configuration IO (Maybe (Progress, [IslandSolution])))
-> (Progress, [IslandSolution])
-> ReaderT Configuration IO (Bool, [(Progress, [IslandSolution])])
forall (m :: * -> *) a.
Monad m =>
Int -> (a -> m (Maybe a)) -> a -> m (Bool, [a])
iterateMaybeM 1000 (Progress
-> ReaderT Configuration IO (Maybe (Progress, [IslandSolution]))
solution (Progress
 -> ReaderT Configuration IO (Maybe (Progress, [IslandSolution])))
-> ((Progress, [IslandSolution]) -> Progress)
-> (Progress, [IslandSolution])
-> ReaderT Configuration IO (Maybe (Progress, [IslandSolution]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Progress, [IslandSolution]) -> Progress
forall a b. (a, b) -> a
fst) ((Progress, [IslandSolution])
 -> ReaderT Configuration IO (Bool, [(Progress, [IslandSolution])]))
-> (Progress -> (Progress, [IslandSolution]))
-> Progress
-> ReaderT Configuration IO (Bool, [(Progress, [IslandSolution])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, []) (Progress
 -> ReaderT Configuration IO (Bool, [(Progress, [IslandSolution])]))
-> SolverT Progress
-> ReaderT Configuration IO (Bool, [(Progress, [IslandSolution])])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress
-> Island -> MMaze -> ReaderT Configuration Identity Progress
islandProgress Progress
p Island
i MMaze
maze')
  ![IslandSolution]
solutions <- [IslandSolution] -> ReaderT Configuration IO [IslandSolution]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([IslandSolution] -> [IslandSolution]
islandConnectivityRefinement ([IslandSolution] -> [IslandSolution])
-> ([(Progress, [IslandSolution])] -> [IslandSolution])
-> [(Progress, [IslandSolution])]
-> [IslandSolution]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[IslandSolution]] -> [IslandSolution]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[IslandSolution]] -> [IslandSolution])
-> ([(Progress, [IslandSolution])] -> [[IslandSolution]])
-> [(Progress, [IslandSolution])]
-> [IslandSolution]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Progress, [IslandSolution]) -> [IslandSolution])
-> [(Progress, [IslandSolution])] -> [[IslandSolution]]
forall a b. (a -> b) -> [a] -> [b]
map (Progress, [IslandSolution]) -> [IslandSolution]
forall a b. (a, b) -> b
snd ([(Progress, [IslandSolution])] -> [IslandSolution])
-> [(Progress, [IslandSolution])] -> [IslandSolution]
forall a b. (a -> b) -> a -> b
$ [(Progress, [IslandSolution])]
solutions)
  Bool -> SolverT () -> SolverT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
capped (SolverT () -> SolverT ()) -> SolverT () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVector (PrimState IO) Piece
-> MVector (PrimState IO) Piece -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
MV.unsafeCopy (MMaze -> IOVector Piece
board MMaze
maze') (MMaze -> IOVector Piece
board MMaze
maze)) -- this copies much more than it needs to, but rarely

  Island -> SolverT Island
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Island
i Island -> (Island -> Island) -> Island
forall a b. a -> (a -> b) -> b
& ASetter Island Island Int Int -> Int -> Island -> Island
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Island Island Int Int
Lens' Island Int
iChoicesL ([IslandSolution] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IslandSolution]
solutions) Island -> (Island -> Island) -> Island
forall a b. a -> (a -> b) -> b
& ASetter Island Island [IslandSolution] [IslandSolution]
-> [IslandSolution] -> Island -> Island
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Island Island [IslandSolution] [IslandSolution]
Lens' Island [IslandSolution]
iSolutionsL [IslandSolution]
solutions)
  where
    constrain :: Configuration -> Configuration
constrain c :: Configuration
c = Configuration
c { cLifespan :: Int
cLifespan = - 1, cBounds :: Bounds
cBounds = (Int -> Bool) -> Bounds
forall a. a -> Maybe a
Just (Int -> IntSet -> Bool
`IntSet.member` IntSet
iBounds), cBench :: Bool
cBench = Bool
True }

    solution :: Progress -> SolverT (Maybe (Progress, [IslandSolution]))
    solution :: Progress
-> ReaderT Configuration IO (Maybe (Progress, [IslandSolution]))
solution p :: Progress
p = (Configuration -> Configuration)
-> SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Configuration -> Configuration
constrain (Progress -> SolverT (Maybe Progress)
solve' Progress
p) SolverT (Maybe Progress)
-> (Maybe Progress
    -> ReaderT Configuration IO (Maybe (Progress, [IslandSolution])))
-> ReaderT Configuration IO (Maybe (Progress, [IslandSolution]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Progress -> ReaderT Configuration IO (Progress, [IslandSolution]))
-> Maybe Progress
-> ReaderT Configuration IO (Maybe (Progress, [IslandSolution]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\p :: Progress
p -> (Progress
p, ) ([IslandSolution] -> (Progress, [IslandSolution]))
-> (IslandSolution -> [IslandSolution])
-> IslandSolution
-> (Progress, [IslandSolution])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IslandSolution -> [IslandSolution]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IslandSolution -> (Progress, [IslandSolution]))
-> ReaderT Configuration IO IslandSolution
-> ReaderT Configuration IO (Progress, [IslandSolution])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Progress -> ReaderT Configuration IO IslandSolution
forall (m :: * -> *). MonadIO m => Progress -> m IslandSolution
islandSolution Progress
p)

    islandSolution :: MonadIO m => Progress -> m IslandSolution
    islandSolution :: Progress -> m IslandSolution
islandSolution Progress{components :: Progress -> Components
components=Components _} = String -> m IslandSolution
forall a. HasCallStack => String -> a
error "not enough info, unlikely"
    islandSolution Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze, components :: Progress -> Components
components=comp :: Components
comp@(Components' compJoin :: IntMap IntSet
compJoin), Space
space :: Space
space :: Progress -> Space
space} = do
      [(Int, Int)]
compEquated <- (Int -> m (Int, Int)) -> [Int] -> m [(Int, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\p :: Int
p -> (, Int
p) (Int -> (Int, Int)) -> m Int -> m (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> m Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze Int
p) ([Int] -> m [(Int, Int)]) -> [Int] -> m [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ IntMap IntSet -> IntMap IntSet -> [Int]
forall a. IntMap a -> IntMap a -> [Int]
compDiff IntMap IntSet
compInit IntMap IntSet
compJoin
      IslandSolution -> m IslandSolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Set Int] -> Priority -> [Unwind] -> IslandSolution
IslandSolution ([(Int, Int)] -> [Set Int]
compParts [(Int, Int)]
compEquated) (Components -> Priority
compCounts Components
comp) (([(Continue, Progress)], [Unwind]) -> [Unwind]
forall a b. (a, b) -> b
snd (([(Continue, Progress)], [Unwind]) -> [Unwind])
-> Space -> [Unwind]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Space
space))
      where
        compDiff :: IntMap a -> IntMap a -> [Int]
compDiff a :: IntMap a
a b :: IntMap a
b = IntSet -> [Int]
IntSet.toList ((IntSet -> IntSet -> IntSet)
-> (IntMap a -> IntSet) -> IntMap a -> IntMap a -> IntSet
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on IntSet -> IntSet -> IntSet
IntSet.difference IntMap a -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap a
a IntMap a
b)
        compParts :: [(Int, Int)] -> [Set Int]
compParts = ((Int, [Int]) -> Set Int) -> [(Int, [Int])] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int)
-> ((Int, [Int]) -> [Int]) -> (Int, [Int]) -> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Int] -> [Int]) -> (Int, [Int]) -> [Int]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)) ([(Int, [Int])] -> [Set Int])
-> ([(Int, Int)] -> [(Int, [Int])]) -> [(Int, Int)] -> [Set Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> [(Int, [Int])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort

    islandProgress :: Progress
-> Island -> MMaze -> ReaderT Configuration Identity Progress
islandProgress _ Island{iConts :: Island -> [Continue]
iConts=[]} _ = String -> ReaderT Configuration Identity Progress
forall a. HasCallStack => String -> a
error "impossible because iConts is result of `group'"
    islandProgress p :: Progress
p Island{iConts :: Island -> [Continue]
iConts=(Continue{Int
cursor :: Int
cursor :: Continue -> Int
cursor}:_)} maze :: MMaze
maze =
      Progress
-> Int
-> (Maybe Continue -> Continue)
-> ReaderT Configuration Identity Progress
prioritizeContinue (Progress
p { MMaze
maze :: MMaze
maze :: MMaze
maze, space :: Space
space = [] }) Int
cursor (((Int -> Identity Int) -> Continue -> Identity Continue)
-> Int -> Continue -> Continue
forall s t a b. ASetter s t a b -> b -> s -> t
set (Int -> Identity Int) -> Continue -> Identity Continue
Lens' Continue Int
islandL 2 (Continue -> Continue)
-> (Maybe Continue -> Continue) -> Maybe Continue -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Continue -> Continue
forall a. HasCallStack => Maybe a -> a
fromJust)

islands :: MonadIO m => Progress -> m [Island]
islands :: Progress -> m [Island]
islands Progress{maze :: Progress -> MMaze
maze=maze :: MMaze
maze@MMaze{Int
width :: Int
width :: MMaze -> Int
width}, Continues
continues :: Continues
continues :: Progress -> Continues
continues} = do
  (Set (Int, Int), [Island]) -> [Island]
forall a b. (a, b) -> b
snd ((Set (Int, Int), [Island]) -> [Island])
-> m (Set (Int, Int), [Island]) -> m [Island]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Int)
 -> (Set (Int, Int), [Island]) -> m (Set (Int, Int), [Island]))
-> [(Int, Int)] -> m (Set (Int, Int), [Island])
forall (t :: * -> *) (m :: * -> *) t a.
(Foldable t, Monad m, Ord t) =>
(t -> (Set t, [a]) -> m (Set t, [a])) -> t t -> m (Set t, [a])
foldIsland (Int, Int)
-> (Set (Int, Int), [Island]) -> m (Set (Int, Int), [Island])
forall (m :: * -> *).
MonadIO m =>
(Int, Int)
-> (Set (Int, Int), [Island]) -> m (Set (Int, Int), [Island])
perIsland (((Int, Continue) -> (Int, Int))
-> [(Int, Continue)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> (Int, Int)
mazeCursor Int
width (Int -> (Int, Int))
-> ((Int, Continue) -> Int) -> (Int, Continue) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continue -> Int
cursor (Continue -> Int)
-> ((Int, Continue) -> Continue) -> (Int, Continue) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Continue) -> Continue
forall a b. (a, b) -> b
snd) ([(Int, Continue)] -> [(Int, Int)])
-> (Continues -> [(Int, Continue)]) -> Continues -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continues -> [(Int, Continue)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Continues -> [(Int, Int)]) -> Continues -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Continues
continues)
  -- pure (islands, foldMap (\Island{iId, iConts = cs} -> IntMap.fromList $ (, iId) <$> map cursor cs) islands)
  where
    foldIsland :: (t -> (Set t, [a]) -> m (Set t, [a])) -> t t -> m (Set t, [a])
foldIsland perIsland :: t -> (Set t, [a]) -> m (Set t, [a])
perIsland continues :: t t
continues =
      (\acc :: (Set t, [a]) -> t -> m (Set t, [a])
acc -> ((Set t, [a]) -> t -> m (Set t, [a]))
-> (Set t, [a]) -> t t -> m (Set t, [a])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Set t, [a]) -> t -> m (Set t, [a])
acc (Set t
forall a. Set a
Set.empty, []) t t
continues) (((Set t, [a]) -> t -> m (Set t, [a])) -> m (Set t, [a]))
-> ((Set t, [a]) -> t -> m (Set t, [a])) -> m (Set t, [a])
forall a b. (a -> b) -> a -> b
$ \acc :: (Set t, [a])
acc@(visited :: Set t
visited, _) cursor :: t
cursor ->
        if t
cursor t -> Set t -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set t
visited then (Set t, [a]) -> m (Set t, [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set t, [a])
acc else t -> (Set t, [a]) -> m (Set t, [a])
perIsland t
cursor (Set t, [a])
acc

    -- border = island's border by continues
    perIsland :: MonadIO m => Cursor -> (Set Cursor, [Island]) -> m (Set Cursor, [Island])
    perIsland :: (Int, Int)
-> (Set (Int, Int), [Island]) -> m (Set (Int, Int), [Island])
perIsland cursor :: (Int, Int)
cursor (visited :: Set (Int, Int)
visited, islands :: [Island]
islands) = do
      (area :: Set (Int, Int)
area, borders :: Set (Int, Int)
borders) <- FillNext m (Set (Int, Int))
-> MMaze -> (Int, Int) -> m (Set (Int, Int), Set (Int, Int))
forall (m :: * -> *) s.
(MonadIO m, Monoid s) =>
FillNext m s -> MMaze -> (Int, Int) -> m (Set (Int, Int), s)
flood (Continues -> FillNext m (Set (Int, Int))
forall (m :: * -> *).
MonadIO m =>
Continues -> FillNext m (Set (Int, Int))
fillNextSolved Continues
continues) MMaze
maze (Int, Int)
cursor
      let iConts :: [Continue]
iConts = (Continues
continues Continues -> Int -> Continue
forall a. IntMap a -> Int -> a
IntMap.!) (Int -> Continue) -> ((Int, Int) -> Int) -> (Int, Int) -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Int, Int) -> Int
mazeFursor Int
width ((Int, Int) -> Continue) -> [(Int, Int)] -> [Continue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
Set.toList Set (Int, Int)
borders
      let iBounds :: IntSet
iBounds = [Int] -> IntSet
IntSet.fromList ([Int] -> IntSet)
-> (Set (Int, Int) -> [Int]) -> Set (Int, Int) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Int, Int) -> Int
mazeFursor Int
width) ([(Int, Int)] -> [Int])
-> (Set (Int, Int) -> [(Int, Int)]) -> Set (Int, Int) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
Set.toList (Set (Int, Int) -> IntSet) -> Set (Int, Int) -> IntSet
forall a b. (a -> b) -> a -> b
$ Set (Int, Int)
area
      let island :: Island
island = Int
-> Int -> [Continue] -> IntSet -> [IslandSolution] -> Int -> Island
Island (Int -> ((Int, Int) -> Int) -> Maybe (Int, Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 (\(x :: Int
x, y :: Int
y) -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) (Set (Int, Int) -> Maybe (Int, Int)
forall a. Set a -> Maybe a
Set.lookupMin Set (Int, Int)
borders)) (Set (Int, Int) -> Int
forall a. Set a -> Int
Set.size Set (Int, Int)
area) [Continue]
iConts IntSet
iBounds [] 0
      (Set (Int, Int), [Island]) -> m (Set (Int, Int), [Island])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set (Int, Int)
visited Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (Int, Int)
borders, Island
island Island -> [Island] -> [Island]
forall a. a -> [a] -> [a]
: [Island]
islands)

    fillNextSolved :: MonadIO m => Continues -> FillNext m (Set Cursor)
    fillNextSolved :: Continues -> FillNext m (Set (Int, Int))
fillNextSolved continues :: Continues
continues _ cur :: (Int, Int)
cur@(x :: Int
x, y :: Int
y) _ deltasWall :: [(Piece, Int)]
deltasWall = do
      Bool
-> StateT (Set (Int, Int)) m () -> StateT (Set (Int, Int)) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) Int -> Continues -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` Continues
continues) (StateT (Set (Int, Int)) m () -> StateT (Set (Int, Int)) m ())
-> StateT (Set (Int, Int)) m () -> StateT (Set (Int, Int)) m ()
forall a b. (a -> b) -> a -> b
$ (Set (Int, Int) -> Set (Int, Int)) -> StateT (Set (Int, Int)) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Int, Int)
cur)
      [(Int, Int)] -> StateT (Set (Int, Int)) m [(Int, Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Int, Int)] -> StateT (Set (Int, Int)) m [(Int, Int)])
-> ([(Piece, Int)] -> [(Int, Int)])
-> [(Piece, Int)]
-> StateT (Set (Int, Int)) m [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Piece, Int) -> (Int, Int)) -> [(Piece, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Int -> (Int, Int)
mazeDelta (Int, Int)
cur (Int -> (Int, Int))
-> ((Piece, Int) -> Int) -> (Piece, Int) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece, Int) -> Int
forall a b. (a, b) -> b
snd) ([(Piece, Int)] -> [(Int, Int)])
-> ([(Piece, Int)] -> [(Piece, Int)])
-> [(Piece, Int)]
-> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Piece, Int) -> Bool) -> [(Piece, Int)] -> [(Piece, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Bool
solved :: Bool
solved :: Piece -> Bool
solved}, _) -> Pix
pipe Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
solved) ([(Piece, Int)] -> StateT (Set (Int, Int)) m [(Int, Int)])
-> [(Piece, Int)] -> StateT (Set (Int, Int)) m [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [(Piece, Int)]
deltasWall

-- | Set up 'Choices' for all 'Continue's and `Piece`s for all unique 'IslandSolution's.
islandHinting :: [Island] -> Progress -> SolverT Progress
islandHinting :: [Island] -> Progress -> SolverT Progress
islandHinting islands :: [Island]
islands p :: Progress
p@Progress{Continues
continues :: Continues
continues :: Progress -> Continues
continues} = do
  Progress
-> [Island]
-> (Progress -> Island -> SolverT Progress)
-> SolverT Progress
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
b -> t a -> (b -> a -> m b) -> m b
reduceM Progress
p [Island]
islands ((Progress -> Island -> SolverT Progress) -> SolverT Progress)
-> (Progress -> Island -> SolverT Progress) -> SolverT Progress
forall a b. (a -> b) -> a -> b
$ \p :: Progress
p _i :: Island
_i@Island{[IslandSolution]
iSolutions :: [IslandSolution]
iSolutions :: Island -> [IslandSolution]
iSolutions} -> do
    (Progress -> [Unwind] -> SolverT Progress)
-> Progress -> [[Unwind]] -> SolverT Progress
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Continues -> Progress -> [Unwind] -> SolverT Progress
forceHints Continues
continues) Progress
p (IslandSolution -> [Unwind]
icHints (IslandSolution -> [Unwind]) -> [IslandSolution] -> [[Unwind]]
forall a b. (a -> b) -> [a] -> [b]
`map` [IslandSolution] -> [IslandSolution]
forall a. [a] -> [a]
unique [IslandSolution]
iSolutions)
  where
    reduceM :: b -> t a -> (b -> a -> m b) -> m b
reduceM a :: b
a l :: t a
l f :: b -> a -> m b
f = (b -> a -> m b) -> b -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM b -> a -> m b
f b
a t a
l

    unique :: [a] -> [a]
unique []      = []
    unique [a :: a
a]  = [a
a]
    unique (_:_:_) = []

{--- Meta solver ---}

islandChoicesParallel :: Progress -> [MMaze] -> [Island] -> SolverT [Island]
islandChoicesParallel :: Progress -> [MMaze] -> [Island] -> SolverT [Island]
islandChoicesParallel p :: Progress
p [copy :: MMaze
copy] islands :: [Island]
islands = [Island] -> (Island -> SolverT Island) -> SolverT [Island]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Island]
islands (MMaze -> Progress -> Island -> SolverT Island
islandChoices MMaze
copy Progress
p)
islandChoicesParallel p :: Progress
p copies :: [MMaze]
copies islands :: [Island]
islands = do
  conf :: Configuration
conf@Configuration{Int
cNumCap :: Int
cNumCap :: Configuration -> Int
cNumCap} <- ReaderT Configuration IO Configuration
forall r (m :: * -> *). MonadReader r m => m r
ask
  let islandChunks :: [(MMaze, [Island])]
islandChunks = [MMaze] -> [[Island]] -> [(MMaze, [Island])]
forall a b. [a] -> [b] -> [(a, b)]
zip [MMaze]
copies ([[Island]] -> [(MMaze, [Island])])
-> ([Island] -> [[Island]]) -> [Island] -> [(MMaze, [Island])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Island]] -> [[Island]]
forall a. [[a]] -> [[a]]
transpose ([[Island]] -> [[Island]])
-> ([Island] -> [[Island]]) -> [Island] -> [[Island]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Island] -> [[Island]]
forall a. HasCallStack => Int -> [a] -> [[a]]
chunksOf Int
cNumCap ([Island] -> [(MMaze, [Island])])
-> [Island] -> [(MMaze, [Island])]
forall a b. (a -> b) -> a -> b
$ [Island]
islands
  ([[Island]] -> [Island])
-> ReaderT Configuration IO [[Island]] -> SolverT [Island]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Island]] -> [Island]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ReaderT Configuration IO [[Island]] -> SolverT [Island])
-> (((MMaze, [Island]) -> IO [Island])
    -> ReaderT Configuration IO [[Island]])
-> ((MMaze, [Island]) -> IO [Island])
-> SolverT [Island]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [[Island]] -> ReaderT Configuration IO [[Island]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Island]] -> ReaderT Configuration IO [[Island]])
-> (((MMaze, [Island]) -> IO [Island]) -> IO [[Island]])
-> ((MMaze, [Island]) -> IO [Island])
-> ReaderT Configuration IO [[Island]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO [Island]] -> IO [[Island]]
forall a. [IO a] -> IO [a]
parallelInterleaved ([IO [Island]] -> IO [[Island]])
-> (((MMaze, [Island]) -> IO [Island]) -> [IO [Island]])
-> ((MMaze, [Island]) -> IO [Island])
-> IO [[Island]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((MMaze, [Island]) -> IO [Island])
 -> [(MMaze, [Island])] -> [IO [Island]])
-> [(MMaze, [Island])]
-> ((MMaze, [Island]) -> IO [Island])
-> [IO [Island]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((MMaze, [Island]) -> IO [Island])
-> [(MMaze, [Island])] -> [IO [Island]]
forall a b. (a -> b) -> [a] -> [b]
map [(MMaze, [Island])]
islandChunks (((MMaze, [Island]) -> IO [Island]) -> SolverT [Island])
-> ((MMaze, [Island]) -> IO [Island]) -> SolverT [Island]
forall a b. (a -> b) -> a -> b
$ \(copy :: MMaze
copy, islands :: [Island]
islands) ->
    [Island] -> (Island -> IO Island) -> IO [Island]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Island]
islands ((SolverT Island -> Configuration -> IO Island)
-> Configuration -> SolverT Island -> IO Island
forall a b c. (a -> b -> c) -> b -> a -> c
flip SolverT Island -> Configuration -> IO Island
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Configuration
conf (SolverT Island -> IO Island)
-> (Island -> SolverT Island) -> Island -> IO Island
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MMaze -> Progress -> Island -> SolverT Island
islandChoices MMaze
copy Progress
p)

islandsWithChoices :: Progress -> SolverT ([Island], [MMaze])
islandsWithChoices :: Progress -> SolverT ([Island], [MMaze])
islandsWithChoices p :: Progress
p@Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} = do
  [MMaze]
copies <- (Int
 -> ReaderT Configuration IO MMaze
 -> ReaderT Configuration IO [MMaze])
-> ReaderT Configuration IO MMaze
-> Int
-> ReaderT Configuration IO [MMaze]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int
-> ReaderT Configuration IO MMaze
-> ReaderT Configuration IO [MMaze]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (MMaze -> ReaderT Configuration IO MMaze
forall (m :: * -> *). MonadIO m => MMaze -> m MMaze
mazeClone MMaze
maze) (Int -> ReaderT Configuration IO [MMaze])
-> ReaderT Configuration IO Int -> ReaderT Configuration IO [MMaze]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Configuration -> Int) -> ReaderT Configuration IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Int
cNumCap
  (, [MMaze]
copies) ([Island] -> ([Island], [MMaze]))
-> SolverT [Island] -> SolverT ([Island], [MMaze])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Progress -> [MMaze] -> [Island] -> SolverT [Island]
islandChoicesParallel Progress
p [MMaze]
copies ([Island] -> SolverT [Island])
-> SolverT [Island] -> SolverT [Island]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Progress -> SolverT [Island]
forall (m :: * -> *). MonadIO m => Progress -> m [Island]
islands Progress
p)

-- | Sovles deterministic parts of the maze in parallel.
solveDetParallel :: Int -> MMaze -> SolverT Progress
solveDetParallel :: Int -> MMaze -> SolverT Progress
solveDetParallel n :: Int
n m :: MMaze
m@MMaze{Int
width :: Int
width :: MMaze -> Int
width} = do
  (_, zeroth :: Progress
zeroth):rest :: [(Int, Progress)]
rest <- MMaze -> SolverT [(Int, Progress)]
divideProgress MMaze
m
  Configuration
conf <- ReaderT Configuration IO Configuration
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Sum iter :: Int
iter, continues :: [(Int, Continue)]
continues) <- IO (Sum Int, [(Int, Continue)])
-> ReaderT Configuration IO (Sum Int, [(Int, Continue)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Sum Int, [(Int, Continue)])
 -> ReaderT Configuration IO (Sum Int, [(Int, Continue)]))
-> ([(Int, Progress)] -> IO (Sum Int, [(Int, Continue)]))
-> [(Int, Progress)]
-> ReaderT Configuration IO (Sum Int, [(Int, Continue)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Sum Int, [(Int, Continue)])] -> (Sum Int, [(Int, Continue)]))
-> IO [(Sum Int, [(Int, Continue)])]
-> IO (Sum Int, [(Int, Continue)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Sum Int, [(Int, Continue)])] -> (Sum Int, [(Int, Continue)])
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (IO [(Sum Int, [(Int, Continue)])]
 -> IO (Sum Int, [(Int, Continue)]))
-> ([(Int, Progress)] -> IO [(Sum Int, [(Int, Continue)])])
-> [(Int, Progress)]
-> IO (Sum Int, [(Int, Continue)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO (Sum Int, [(Int, Continue)])]
-> IO [(Sum Int, [(Int, Continue)])]
forall a. [IO a] -> IO [a]
parallelInterleaved ([IO (Sum Int, [(Int, Continue)])]
 -> IO [(Sum Int, [(Int, Continue)])])
-> ([(Int, Progress)] -> [IO (Sum Int, [(Int, Continue)])])
-> [(Int, Progress)]
-> IO [(Sum Int, [(Int, Continue)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Progress) -> IO (Sum Int, [(Int, Continue)]))
-> [(Int, Progress)] -> [IO (Sum Int, [(Int, Continue)])]
forall a b. (a -> b) -> [a] -> [b]
map ((Progress -> (Sum Int, [(Int, Continue)]))
-> IO Progress -> IO (Sum Int, [(Int, Continue)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Progress -> (Sum Int, [(Int, Continue)])
progressExtract (IO Progress -> IO (Sum Int, [(Int, Continue)]))
-> ((Int, Progress) -> IO Progress)
-> (Int, Progress)
-> IO (Sum Int, [(Int, Continue)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> (Int, Progress) -> IO Progress
solvePar Configuration
conf) ([(Int, Progress)]
 -> ReaderT Configuration IO (Sum Int, [(Int, Continue)]))
-> [(Int, Progress)]
-> ReaderT Configuration IO (Sum Int, [(Int, Continue)])
forall a b. (a -> b) -> a -> b
$ [(Int, Progress)]
rest
  ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues (Progress
zeroth { Int
iter :: Int
iter :: Int
iter, depth :: Int
depth = Int
iter }) (((Int, Continue) -> (Int, Maybe Continue -> Continue))
-> [(Int, Continue)] -> [(Int, Maybe Continue -> Continue)]
forall a b. (a -> b) -> [a] -> [b]
map ((\c :: Continue
c -> (Continue -> Int
cursor Continue
c, Continue -> Maybe Continue -> Continue
forall (m :: * -> *) a. Monad m => a -> m a
return Continue
c)) (Continue -> (Int, Maybe Continue -> Continue))
-> ((Int, Continue) -> Continue)
-> (Int, Continue)
-> (Int, Maybe Continue -> Continue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Continue) -> Continue
forall a b. (a, b) -> b
snd) [(Int, Continue)]
continues))
  where
    solvePar :: Configuration -> (Int, Progress) -> IO Progress
solvePar conf :: Configuration
conf (n :: Int
n, p :: Progress
p) = Maybe Progress -> Progress
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Progress -> Progress) -> IO (Maybe Progress) -> IO Progress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SolverT (Maybe Progress) -> Configuration -> IO (Maybe Progress)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Progress -> SolverT (Maybe Progress)
solve' Progress
p) (Configuration -> Int -> Configuration
configuration Configuration
conf Int
n)
    progressExtract :: Progress -> (Sum Int, [(Int, Continue)])
progressExtract Progress{Int
iter :: Int
iter :: Progress -> Int
iter, Continues
continues :: Continues
continues :: Progress -> Continues
continues} = (Int -> Sum Int
forall a. a -> Sum a
Sum Int
iter, Continues -> [(Int, Continue)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList Continues
continues)
    configuration :: Configuration -> Int -> Configuration
configuration c :: Configuration
c n :: Int
n = Configuration
c
      { cBounds :: Bounds
cBounds = (Int -> Bool) -> Bounds
forall a. a -> Maybe a
Just (\f :: Int
f -> MMaze -> (Int, Int) -> Int
mazeQuadrant MMaze
m (Int -> Int -> (Int, Int)
mazeCursor Int
width Int
f) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n)
      , cMode :: SolveMode
cMode = SolveMode
SolveParallel }

    divideProgress :: MMaze -> SolverT [(Int, Progress)]
    divideProgress :: MMaze -> SolverT [(Int, Progress)]
divideProgress m :: MMaze
m@MMaze{Int
width :: Int
width :: MMaze -> Int
width, [Int]
trivials :: [Int]
trivials :: MMaze -> [Int]
trivials} =
      let
        p :: Progress
p = Int
-> Int
-> Priority
-> Continues
-> Components
-> Space
-> MMaze
-> Progress
Progress 0 0 Priority
forall a. IntMap a
IntMap.empty Continues
forall a. IntMap a
IntMap.empty (Priority -> Components
Components Priority
forall a. IntMap a
IntMap.empty) [] MMaze
m
        continue :: (Int, Int) -> f (Int, m Continue)
continue (i :: Int
i, c :: Int
c) = (\Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
initChoices :: Int
initChoices :: Piece -> Int
initChoices} -> (Int
c, Continue -> m Continue
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Pix -> Int -> Int -> Int -> Int -> Int -> Int -> Continue
Continue Int
c Pix
pipe Int
c 0 (-Int
i) 0 0 Int
initChoices))) (Piece -> (Int, m Continue)) -> f Piece -> f (Int, m Continue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> f Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
m Int
c
        quad :: (Int, Int) -> Int
quad = MMaze -> (Int, Int) -> Int
mazeQuadrant MMaze
m
      in do
        [(Int, Maybe Continue -> Continue)]
continues <- ((Int, Int)
 -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
-> [(Int, Int)]
-> ReaderT Configuration IO [(Int, Maybe Continue -> Continue)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int, Int)
-> ReaderT Configuration IO (Int, Maybe Continue -> Continue)
forall (f :: * -> *) (m :: * -> *).
(MonadIO f, Monad m) =>
(Int, Int) -> f (Int, m Continue)
continue ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Int]
trivials)
        ReaderT Configuration Identity [(Int, Progress)]
-> SolverT [(Int, Progress)]
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (ReaderT Configuration Identity [(Int, Progress)]
 -> SolverT [(Int, Progress)])
-> ([(Int, Maybe Continue -> Continue)]
    -> ReaderT Configuration Identity [(Int, Progress)])
-> [(Int, Maybe Continue -> Continue)]
-> SolverT [(Int, Progress)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [(Int, Maybe Continue -> Continue)])
 -> ReaderT Configuration Identity (Int, Progress))
-> [(Int, [(Int, Maybe Continue -> Continue)])]
-> ReaderT Configuration Identity [(Int, Progress)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([(Int, Maybe Continue -> Continue)]
 -> ReaderT Configuration Identity Progress)
-> (Int, [(Int, Maybe Continue -> Continue)])
-> ReaderT Configuration Identity (Int, Progress)
forall s t a b. Field2 s t a b => Lens s t a b
_2 (Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues Progress
p)) ([(Int, [(Int, Maybe Continue -> Continue)])]
 -> ReaderT Configuration Identity [(Int, Progress)])
-> ([(Int, Maybe Continue -> Continue)]
    -> [(Int, [(Int, Maybe Continue -> Continue)])])
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity [(Int, Progress)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, (Int, Maybe Continue -> Continue))]
-> [(Int, [(Int, Maybe Continue -> Continue)])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort ([(Int, (Int, Maybe Continue -> Continue))]
 -> [(Int, [(Int, Maybe Continue -> Continue)])])
-> ([(Int, Maybe Continue -> Continue)]
    -> [(Int, (Int, Maybe Continue -> Continue))])
-> [(Int, Maybe Continue -> Continue)]
-> [(Int, [(Int, Maybe Continue -> Continue)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Maybe Continue -> Continue)
 -> (Int, (Int, Maybe Continue -> Continue)))
-> [(Int, Maybe Continue -> Continue)]
-> [(Int, (Int, Maybe Continue -> Continue))]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: (Int, Maybe Continue -> Continue)
c -> ((Int, Int) -> Int
quad ((Int, Int) -> Int)
-> ((Int, Maybe Continue -> Continue) -> (Int, Int))
-> (Int, Maybe Continue -> Continue)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> (Int, Int)
mazeCursor Int
width (Int -> (Int, Int))
-> ((Int, Maybe Continue -> Continue) -> Int)
-> (Int, Maybe Continue -> Continue)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Continue -> Continue) -> Int
forall a b. (a, b) -> a
fst ((Int, Maybe Continue -> Continue) -> Int)
-> (Int, Maybe Continue -> Continue) -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Maybe Continue -> Continue)
c, (Int, Maybe Continue -> Continue)
c)) ([(Int, Maybe Continue -> Continue)] -> SolverT [(Int, Progress)])
-> [(Int, Maybe Continue -> Continue)] -> SolverT [(Int, Progress)]
forall a b. (a -> b) -> a -> b
$ [(Int, Maybe Continue -> Continue)]
continues

    mazeQuadrant :: MMaze -> Cursor -> Int
    mazeQuadrant :: MMaze -> (Int, Int) -> Int
mazeQuadrant MMaze{Int
width :: Int
width :: MMaze -> Int
width} = (Int -> Int -> (Int, Int) -> Int)
-> (Int, Int) -> (Int, Int) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Int -> Int -> (Int, Int) -> Int
quadrant Int
width) (Int -> (Int, Int)
coeff Int
n)
      where
        splits :: [(Int, (Int, Int))]
splits = [(1, (1, 1)), (2, (2, 1)), (4, (2, 2)), (6, (3, 3)), (8, (4, 2)), (12, (4, 3)), (16, (4, 4)), (64, (8, 8))]
        coeff :: Int -> (Int, Int)
coeff n :: Int
n = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Int, Int)
forall a. HasCallStack => String -> a
error "define split for capabilities") (Int -> [(Int, (Int, Int))] -> Maybe (Int, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n [(Int, (Int, Int))]
splits)

        -- | Returns a unique quadrant id for a 0-based n-size grid split into s*s quadrants
        -- which separated by lines of zeros. May be useful as the key function for groupSortOn.
        -- https://stackoverflow.com/questions/2745074/fast-ceiling-of-an-integer-division-in-c-c
        quadrant :: Int -> Int -> Int -> Cursor -> Int
        quadrant :: Int -> Int -> Int -> (Int, Int) -> Int
quadrant n' :: Int
n' sx :: Int
sx sy :: Int
sy (x' :: Int
x', y' :: Int
y') = (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
qx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wrap Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
qy)
          where
            (x :: Int
x, y :: Int
y, qx :: Int
qx, qy :: Int
qy, n :: Int
n) = (Int
x' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 , Int
y' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
            l :: Int
l = if Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
qx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 Bool -> Bool -> Bool
|| Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
qy Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 then 0 else 1
            wrap :: Int
wrap = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
qy) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
qy -- wrap x = ceiling (n / q)

-- | Solve all island's pieces which remain the same in all solutions.
islandStaticHints :: [Island] -> Progress -> SolverT Progress
islandStaticHints :: [Island] -> Progress -> SolverT Progress
islandStaticHints islands :: [Island]
islands p :: Progress
p@Progress{Continues
continues :: Continues
continues :: Progress -> Continues
continues} =
  (Progress -> Island -> SolverT Progress)
-> Progress -> [Island] -> SolverT Progress
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\p :: Progress
p _i :: Island
_i@Island{[IslandSolution]
iSolutions :: [IslandSolution]
iSolutions :: Island -> [IslandSolution]
iSolutions} -> Continues -> Progress -> [Unwind] -> SolverT Progress
forceHints Continues
continues Progress
p ([IslandSolution] -> [Unwind]
uniqueHints [IslandSolution]
iSolutions)) Progress
p [Island]
islands
  where
    uniqueHints :: [IslandSolution] -> [Unwind]
uniqueHints [solution :: IslandSolution
solution] = (Unwind -> Unwind) -> [Unwind] -> [Unwind]
forall a b. (a -> b) -> [a] -> [b]
map Unwind -> Unwind
unwindEraseBefore (IslandSolution -> [Unwind]
icHints IslandSolution
solution)
    uniqueHints solutions :: [IslandSolution]
solutions = Set Unwind -> [Unwind]
forall a. Set a -> [a]
Set.toList ([IslandSolution] -> Set Unwind
solutionIntersection [IslandSolution]
solutions)

    solutionIntersection :: [IslandSolution] -> Set Unwind
solutionIntersection = (Set Unwind -> Set Unwind -> Set Unwind)
-> [Set Unwind] -> Set Unwind
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldl1 Set Unwind -> Set Unwind -> Set Unwind
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([Set Unwind] -> Set Unwind)
-> ([IslandSolution] -> [Set Unwind])
-> [IslandSolution]
-> Set Unwind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IslandSolution -> Set Unwind) -> [IslandSolution] -> [Set Unwind]
forall a b. (a -> b) -> [a] -> [b]
map ([Unwind] -> Set Unwind
forall a. Ord a => [a] -> Set a
Set.fromList ([Unwind] -> Set Unwind)
-> (IslandSolution -> [Unwind]) -> IslandSolution -> Set Unwind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwind -> Unwind) -> [Unwind] -> [Unwind]
forall a b. (a -> b) -> [a] -> [b]
map Unwind -> Unwind
unwindEraseBefore ([Unwind] -> [Unwind])
-> (IslandSolution -> [Unwind]) -> IslandSolution -> [Unwind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IslandSolution -> [Unwind]
icHints)

    unwindEraseBefore :: Unwind -> Unwind
unwindEraseBefore (UnSolve fursor :: Int
fursor _ pix :: Pix
pix) = Int -> Pix -> Pix -> Unwind
UnSolve Int
fursor 0 Pix
pix
    unwindEraseBefore a :: Unwind
a = Unwind
a

initProgress :: MMaze -> SolverT Progress
initProgress :: MMaze -> SolverT Progress
initProgress m :: MMaze
m@MMaze{[Int]
trivials :: [Int]
trivials :: MMaze -> [Int]
trivials} =
  let
    p :: Progress
p = Int
-> Int
-> Priority
-> Continues
-> Components
-> Space
-> MMaze
-> Progress
Progress 0 0 Priority
forall a. IntMap a
IntMap.empty Continues
forall a. IntMap a
IntMap.empty (Priority -> Components
Components Priority
forall a. IntMap a
IntMap.empty) [] MMaze
m
    continue :: (Int, Int) -> f (Int, m Continue)
continue (i :: Int
i, c :: Int
c) = (\Piece{Pix
pipe :: Pix
pipe :: Piece -> Pix
pipe, Int
initChoices :: Int
initChoices :: Piece -> Int
initChoices} -> (Int
c, Continue -> m Continue
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Pix -> Int -> Int -> Int -> Int -> Int -> Int -> Continue
Continue Int
c Pix
pipe Int
c 0 (-Int
i) 0 0 Int
initChoices))) (Piece -> (Int, m Continue)) -> f Piece -> f (Int, m Continue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> f Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
m Int
c
  in ReaderT Configuration Identity Progress -> SolverT Progress
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (ReaderT Configuration Identity Progress -> SolverT Progress)
-> ([(Int, Maybe Continue -> Continue)]
    -> ReaderT Configuration Identity Progress)
-> [(Int, Maybe Continue -> Continue)]
-> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress
-> [(Int, Maybe Continue -> Continue)]
-> ReaderT Configuration Identity Progress
prioritizeContinues Progress
p ([(Int, Maybe Continue -> Continue)] -> SolverT Progress)
-> ReaderT Configuration IO [(Int, Maybe Continue -> Continue)]
-> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Int, Int)
 -> ReaderT Configuration IO (Int, Maybe Continue -> Continue))
-> [(Int, Int)]
-> ReaderT Configuration IO [(Int, Maybe Continue -> Continue)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int, Int)
-> ReaderT Configuration IO (Int, Maybe Continue -> Continue)
forall (f :: * -> *) (m :: * -> *).
(MonadIO f, Monad m) =>
(Int, Int) -> f (Int, m Continue)
continue ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Int]
trivials)

-- | First deterministic, possibly parallel run-through solve stage.
solveBasic :: MMaze -> SolverT Progress
solveBasic :: MMaze -> SolverT Progress
solveBasic maze :: MMaze
maze = do
  ReaderT Configuration IO Bool -> SolverT () -> SolverT ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Configuration -> Bool) -> ReaderT Configuration IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bool -> Bool
not (Bool -> Bool) -> (Configuration -> Bool) -> Configuration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Bool
cBench)) (SolverT () -> SolverT ()) -> SolverT () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ SolverT Progress -> SolverT ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SolverT Progress -> SolverT ())
-> (Progress -> SolverT Progress) -> Progress -> SolverT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Progress -> SolverT Progress
renderImage' "start" (Progress -> SolverT ()) -> SolverT Progress -> SolverT ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> SolverT Progress
initProgress MMaze
maze
  Progress
p <- MMaze -> Int -> SolverT Progress
initSolve MMaze
maze (Int -> SolverT Progress)
-> ReaderT Configuration IO Int -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Configuration -> Int) -> ReaderT Configuration IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Int
cNumCap
  Progress
p <- Bool -> Progress -> SolverT Progress
forall (m :: * -> *). MonadIO m => Bool -> Progress -> m Progress
componentRecalc Bool
True (Progress -> SolverT Progress)
-> (Maybe Progress -> Progress)
-> Maybe Progress
-> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Progress -> Progress
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Progress -> SolverT Progress)
-> SolverT (Maybe Progress) -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall (m :: * -> *) a.
ReaderT Configuration m a -> ReaderT Configuration m a
determinstically (Progress -> SolverT (Maybe Progress)
solve' Progress
p)
  String -> Progress -> SolverT Progress
renderImage' "islandize" Progress
p
  where
    initSolve :: MMaze -> Int -> SolverT Progress
initSolve m :: MMaze
m@MMaze{Int
level :: Int
level :: MMaze -> Int
level} n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& 4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
level =
      Bool -> Progress -> SolverT Progress
forall (m :: * -> *). MonadIO m => Bool -> Progress -> m Progress
componentRecalc Bool
False (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Progress -> SolverT Progress
renderImage' "parallel" (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> MMaze -> SolverT Progress
solveDetParallel Int
n MMaze
m
    initSolve m :: MMaze
m _ = MMaze -> SolverT Progress
initProgress MMaze
m

    -- | Progress.components = Components -> Components'
    componentRecalc :: MonadIO m => Bool -> Progress -> m Progress
    componentRecalc :: Bool -> Progress -> m Progress
componentRecalc deep :: Bool
deep p :: Progress
p@Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze, Continues
continues :: Continues
continues :: Progress -> Continues
continues} = do
      IntMap IntSet
comps <- (IntMap IntSet -> IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet -> [IntMap IntSet] -> IntMap IntSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union) IntMap IntSet
forall a. IntMap a
IntMap.empty ([IntMap IntSet] -> IntMap IntSet)
-> m [IntMap IntSet] -> m (IntMap IntSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Continue) -> m (IntMap IntSet))
-> [(Int, Continue)] -> m [IntMap IntSet]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int, Continue) -> m (IntMap IntSet)
forall (f :: * -> *) a.
MonadIO f =>
(a, Continue) -> f (IntMap IntSet)
component (Continues -> [(Int, Continue)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList Continues
continues)
      Progress -> m Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progress -> m Progress)
-> (Components -> Progress) -> Components -> m Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\c :: Components
c -> Progress
p { components :: Components
components = Components
c }) (Components -> m Progress) -> Components -> m Progress
forall a b. (a -> b) -> a -> b
$ if Bool
deep then IntMap IntSet -> Components
Components' IntMap IntSet
comps else Priority -> Components
Components ((IntSet -> Int) -> IntMap IntSet -> Priority
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map IntSet -> Int
IntSet.size IntMap IntSet
comps)
      where component :: (a, Continue) -> f (IntMap IntSet)
component (_, Continue{Int
origin :: Int
origin :: Continue -> Int
origin, Int
cursor :: Int
cursor :: Continue -> Int
cursor}) = Int -> IntSet -> IntMap IntSet
forall a. Int -> a -> IntMap a
IntMap.singleton (Int -> IntSet -> IntMap IntSet)
-> f Int -> f (IntSet -> IntMap IntSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> Int -> f Int
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Int
partEquate MMaze
maze Int
origin f (IntSet -> IntMap IntSet) -> f IntSet -> f (IntMap IntSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntSet -> f IntSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IntSet
IntSet.singleton Int
cursor)

solveIslandStatic :: Progress -> SolverT Progress
solveIslandStatic :: Progress -> SolverT Progress
solveIslandStatic p :: Progress
p = do
  (islands :: [Island]
islands, _) <- Progress -> SolverT ([Island], [MMaze])
islandsWithChoices Progress
p
  Progress
p <- (Maybe Progress -> Progress)
-> SolverT (Maybe Progress) -> SolverT Progress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Progress -> Maybe Progress -> Progress
forall a. a -> Maybe a -> a
fromMaybe Progress
p) (SolverT (Maybe Progress) -> SolverT Progress)
-> (Progress -> SolverT (Maybe Progress))
-> Progress
-> SolverT Progress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall (m :: * -> *) a.
ReaderT Configuration m a -> ReaderT Configuration m a
determinstically (SolverT (Maybe Progress) -> SolverT (Maybe Progress))
-> (Progress -> SolverT (Maybe Progress))
-> Progress
-> SolverT (Maybe Progress)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress -> SolverT (Maybe Progress)
solve' (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Island] -> Progress -> SolverT Progress
islandStaticHints [Island]
islands Progress
p
  String -> Progress -> SolverT Progress
renderImage' "islandize-static" Progress
p

solveTrivialIslands :: Progress -> SolverT Progress
solveTrivialIslands :: Progress -> SolverT Progress
solveTrivialIslands p :: Progress
p@Progress{maze :: Progress -> MMaze
maze=MMaze{Int
level :: Int
level :: MMaze -> Int
level}} | 6 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level = Progress -> SolverT Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
p
solveTrivialIslands p :: Progress
p = do
  (islands :: [Island]
islands, copies :: [MMaze]
copies) <- Progress -> SolverT ([Island], [MMaze])
islandsWithChoices Progress
p
  [MMaze] -> [Island] -> Progress -> SolverT Progress
solveTrivialIslands' [MMaze]
copies [Island]
islands (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Island] -> Progress -> SolverT Progress
islandHinting [Island]
islands (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Progress -> SolverT Progress
islandize Progress
p
  where
    solveTrivialIslands' :: [MMaze] -> [Island] -> Progress -> SolverT Progress
    solveTrivialIslands' :: [MMaze] -> [Island] -> Progress -> SolverT Progress
solveTrivialIslands' _ _ p :: Progress
p@Progress{Int
depth :: Int
depth :: Progress -> Int
depth, maze :: Progress -> MMaze
maze=MMaze{Int
size :: Int
size :: MMaze -> Int
size}} | Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size = Progress -> SolverT Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
p
    solveTrivialIslands' copies :: [MMaze]
copies islands :: [Island]
islands p :: Progress
p@Progress{MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} = Maybe Continue -> SolverT Progress
forall a. Maybe a -> SolverT Progress
solveT (Maybe Continue -> SolverT Progress)
-> ReaderT Configuration IO (Maybe Continue) -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Configuration IO (Maybe Continue)
-> ReaderT Configuration IO (Maybe Continue)
forall (m :: * -> *) a.
ReaderT Configuration m a -> ReaderT Configuration m a
determinstically (ReaderT Configuration Identity (Maybe Continue)
-> ReaderT Configuration IO (Maybe Continue)
forall r b. ReaderT r Identity b -> ReaderT r IO b
toSolverT (Progress -> ReaderT Configuration Identity (Maybe Continue)
findContinue Progress
p))
      where
        solveT :: Maybe a -> SolverT Progress
solveT Nothing = Progress -> SolverT Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progress
p
        solveT (Just _) = do
          (_space :: Space
_space, solve :: Progress
solve) <- (Space -> (Space, Space)) -> Progress -> (Space, Progress)
Lens' Progress Space
spaceL ((,) (Space -> Space -> (Space, Space))
-> (Space -> Space) -> Space -> (Space, Space)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Space -> Space
forall a. a -> a
id) (Progress -> (Space, Progress))
-> (Maybe Progress -> Progress)
-> Maybe Progress
-> (Space, Progress)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Progress -> Progress
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Progress -> (Space, Progress))
-> SolverT (Maybe Progress)
-> ReaderT Configuration IO (Space, Progress)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SolverT (Maybe Progress) -> SolverT (Maybe Progress)
forall (m :: * -> *) a.
ReaderT Configuration m a -> ReaderT Configuration m a
determinsticallyI (Progress -> SolverT (Maybe Progress)
solve' Progress
p)
          [Island]
islands <- (Island -> ReaderT Configuration IO Bool)
-> [Island] -> SolverT [Island]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Piece -> Bool)
-> ReaderT Configuration IO Piece -> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool) -> (Piece -> Bool) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Bool
solved) (ReaderT Configuration IO Piece -> ReaderT Configuration IO Bool)
-> (Island -> ReaderT Configuration IO Piece)
-> Island
-> ReaderT Configuration IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MMaze -> Int -> ReaderT Configuration IO Piece
forall (m :: * -> *). MonadIO m => MMaze -> Int -> m Piece
mazeRead MMaze
maze (Int -> ReaderT Configuration IO Piece)
-> (Island -> Int) -> Island -> ReaderT Configuration IO Piece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continue -> Int
cursor (Continue -> Int) -> (Island -> Continue) -> Island -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Continue] -> Continue
forall a. [a] -> a
head ([Continue] -> Continue)
-> (Island -> [Continue]) -> Island -> Continue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Island -> [Continue]
iConts) [Island]
islands
          [Island]
islands <- Progress -> [MMaze] -> [Island] -> SolverT [Island]
islandChoicesParallel Progress
p [MMaze]
copies [Island]
islands
          [MMaze] -> [Island] -> Progress -> SolverT Progress
solveTrivialIslands' [MMaze]
copies [] (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Island] -> Progress -> SolverT Progress
islandHinting [Island]
islands Progress
solve

-- | Solve with backtracking, return the same maze, if search space exhausted.
solveBacktrack :: Progress -> SolverT Progress
solveBacktrack :: Progress -> SolverT Progress
solveBacktrack p :: Progress
p = (Maybe Progress -> Progress)
-> SolverT (Maybe Progress) -> SolverT Progress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Progress -> Maybe Progress -> Progress
forall a. a -> Maybe a -> a
fromMaybe Progress
p) (Progress -> SolverT (Maybe Progress)
solve' Progress
p)

-- | Solver main, returns solved maze
solve :: MMaze -> SolverT MMaze
solve :: MMaze -> ReaderT Configuration IO MMaze
solve maze :: MMaze
maze@MMaze{TimeSpec
time :: TimeSpec
time :: MMaze -> TimeSpec
time} = do
  Progress
p <- Progress -> SolverT Progress
solveBacktrack (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Progress -> SolverT Progress
solveTrivialIslands (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Progress -> SolverT Progress
solveIslandStatic (Progress -> SolverT Progress)
-> SolverT Progress -> SolverT Progress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> SolverT Progress
solveBasic MMaze
maze
  TimeSpec
time' <- TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec (TimeSpec -> TimeSpec -> TimeSpec)
-> ReaderT Configuration IO TimeSpec
-> ReaderT Configuration IO (TimeSpec -> TimeSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TimeSpec -> ReaderT Configuration IO TimeSpec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
getTime Clock
Monotonic) ReaderT Configuration IO (TimeSpec -> TimeSpec)
-> ReaderT Configuration IO TimeSpec
-> ReaderT Configuration IO TimeSpec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TimeSpec -> ReaderT Configuration IO TimeSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeSpec
time
  let Progress{Int
iter :: Int
iter :: Progress -> Int
iter, Int
depth :: Int
depth :: Progress -> Int
depth, MMaze
maze :: MMaze
maze :: Progress -> MMaze
maze} = Progress
p
  let ratio :: Double
ratio = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iter Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth :: Double
  let runtime :: Double
runtime = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs TimeSpec
time') Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 1_000_000_000 :: Double
  IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String -> Int -> Int -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf "\x1b[2K%i/%i, ratio: %0.5f, time: %0.2fs" Int
iter Int
depth Double
ratio Double
runtime))
  MMaze
maze MMaze -> SolverT Progress -> ReaderT Configuration IO MMaze
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Progress -> SolverT Progress
renderImage' "done" Progress
p

solveIO :: MMaze -> IO MMaze
solveIO :: MMaze -> IO MMaze
solveIO m :: MMaze
m = MMaze -> IO Configuration
configuration MMaze
m IO Configuration -> (Configuration -> IO MMaze) -> IO MMaze
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Configuration IO MMaze -> Configuration -> IO MMaze
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MMaze -> ReaderT Configuration IO MMaze
solve MMaze
m)

{--- Main ---}

verify :: MMaze -> SolverT Bool
verify :: MMaze -> ReaderT Configuration IO Bool
verify maze :: MMaze
maze@MMaze{IOVector Piece
board :: IOVector Piece
board :: MMaze -> IOVector Piece
board, Int
size :: Int
size :: MMaze -> Int
size} = do
  (Sum spaces :: Int
spaces) <- (Sum Int -> Piece -> Sum Int) -> Sum Int -> Vector Piece -> Sum Int
forall b a. Storable b => (a -> b -> a) -> a -> Vector b -> a
V.foldl' ((Piece -> Sum Int -> Sum Int) -> Sum Int -> Piece -> Sum Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Sum Int -> Sum Int -> Sum Int
forall a. Monoid a => a -> a -> a
mappend (Sum Int -> Sum Int -> Sum Int)
-> (Piece -> Sum Int) -> Piece -> Sum Int -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> (Piece -> Int) -> Piece -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (Piece -> Bool) -> Piece -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pix -> Pix -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (Pix -> Bool) -> (Piece -> Pix) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Pix
pipe))) Sum Int
forall a. Monoid a => a
mempty (Vector Piece -> Sum Int)
-> ReaderT Configuration IO (Vector Piece)
-> ReaderT Configuration IO (Sum Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ReaderT Configuration IO)) Piece
-> ReaderT Configuration IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState (ReaderT Configuration IO)) Piece
board
  Bool
required <- (Configuration -> Bool) -> ReaderT Configuration IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bool -> Bool
not (Bool -> Bool) -> (Configuration -> Bool) -> Configuration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Bool
cBench)
  if Bool
required
  then (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
spaces Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool)
-> ((Set (Int, Int), ()) -> Int) -> (Set (Int, Int), ()) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Int, Int) -> Int
forall a. Set a -> Int
Set.size (Set (Int, Int) -> Int)
-> ((Set (Int, Int), ()) -> Set (Int, Int))
-> (Set (Int, Int), ())
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Int, Int), ()) -> Set (Int, Int)
forall a b. (a, b) -> a
fst ((Set (Int, Int), ()) -> Bool)
-> SolverT (Set (Int, Int), ()) -> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FillNext (ReaderT Configuration IO) ()
-> MMaze -> (Int, Int) -> SolverT (Set (Int, Int), ())
forall (m :: * -> *) s.
(MonadIO m, Monoid s) =>
FillNext m s -> MMaze -> (Int, Int) -> m (Set (Int, Int), s)
flood FillNext (ReaderT Configuration IO) ()
fillNextValid MMaze
maze (0, 0)
  else Bool -> ReaderT Configuration IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  where
    fillNextValid :: FillNext SolverT ()
    fillNextValid :: FillNext (ReaderT Configuration IO) ()
fillNextValid maze :: MMaze
maze cur :: (Int, Int)
cur Piece{pipe :: Piece -> Pix
pipe=Pix
this} deltasWalls :: [(Piece, Int)]
deltasWalls = [(Int, Int)] -> StateT () (ReaderT Configuration IO) [(Int, Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Int, Int)] -> StateT () (ReaderT Configuration IO) [(Int, Int)])
-> [(Int, Int)]
-> StateT () (ReaderT Configuration IO) [(Int, Int)]
forall a b. (a -> b) -> a -> b
$
      if Pix -> [(Piece, Int)] -> Int -> Bool
validateRotation Pix
this [(Piece, Int)]
deltasWalls 0
      then ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (MMaze -> (Int, Int) -> Bool
mazeBounded MMaze
maze) ([(Int, Int)] -> [(Int, Int)])
-> ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Int -> (Int, Int)
mazeDelta (Int, Int)
cur) ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Pix -> [Int]
forall p. Bits p => p -> [Int]
pixDirections Pix
this
      else []

storeBad :: Int -> MMaze -> MMaze -> SolverT MMaze
storeBad :: Int -> MMaze -> MMaze -> ReaderT Configuration IO MMaze
storeBad level :: Int
level original :: MMaze
original solved :: MMaze
solved = (MMaze
solved MMaze -> SolverT () -> ReaderT Configuration IO MMaze
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (SolverT () -> ReaderT Configuration IO MMaze)
-> SolverT () -> ReaderT Configuration IO MMaze
forall a b. (a -> b) -> a -> b
$ do
  ReaderT Configuration IO Bool -> SolverT () -> SolverT ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool)
-> ReaderT Configuration IO Bool -> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> ReaderT Configuration IO Bool
verify MMaze
solved) (SolverT () -> SolverT ()) -> SolverT () -> SolverT ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String -> Int -> String
forall r. PrintfType r => String -> r
printf "storing bad level %i solve" Int
level))
    MMaze -> String -> SolverT ()
forall (m :: * -> *). MonadIO m => MMaze -> String -> m ()
mazeStore MMaze
original ("samples/bad-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
level)

rotateStr :: Int -> MMaze -> MMaze -> IO [Text]
rotateStr :: Int -> MMaze -> MMaze -> IO [Text]
rotateStr split :: Int
split input :: MMaze
input solved :: MMaze
solved =
  ([((Int, Int), Int)] -> Text) -> [[((Int, Int), Int)]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [((Int, Int), Int)] -> Text
concatenate ([[((Int, Int), Int)]] -> [Text])
-> ([((Int, Int), Int)] -> [[((Int, Int), Int)]])
-> [((Int, Int), Int)]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [((Int, Int), Int)] -> [[((Int, Int), Int)]]
forall a. HasCallStack => Int -> [a] -> [[a]]
chunksOf Int
split ([((Int, Int), Int)] -> [Text])
-> IO [((Int, Int), Int)] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> MMaze -> IO [((Int, Int), Int)]
rotations MMaze
input MMaze
solved
  where
    concatenate :: [(Cursor, Rotation)] -> Text
    concatenate :: [((Int, Int), Int)] -> Text
concatenate =
      (String -> Text
T.pack "rotate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> ([((Int, Int), Int)] -> Text) -> [((Int, Int), Int)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate (String -> Text
T.pack "\n")
      ([Text] -> Text)
-> ([((Int, Int), Int)] -> [Text]) -> [((Int, Int), Int)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((Int, Int), Int)] -> (((Int, Int), Int) -> [Text]) -> [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\((x :: Int
x, y :: Int
y), r :: Int
r) -> Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
r (String -> Text
T.pack (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf "%i %i" Int
x Int
y))))

    rotations :: MMaze -> MMaze -> IO [(Cursor, Rotation)]
    rotations :: MMaze -> MMaze -> IO [((Int, Int), Int)]
rotations MMaze{Int
width :: Int
width :: MMaze -> Int
width, board :: MMaze -> IOVector Piece
board=IOVector Piece
input} MMaze{board :: MMaze -> IOVector Piece
board=IOVector Piece
solved} = do
      (as :: [Piece]
as, bs :: [Piece]
bs) <- ([Piece] -> [Piece] -> ([Piece], [Piece]))
-> (Vector Piece -> [Piece])
-> Vector Piece
-> Vector Piece
-> ([Piece], [Piece])
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on (,) Vector Piece -> [Piece]
forall a. Storable a => Vector a -> [a]
V.toList (Vector Piece -> Vector Piece -> ([Piece], [Piece]))
-> IO (Vector Piece) -> IO (Vector Piece -> ([Piece], [Piece]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Piece -> IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState IO) Piece
input IO (Vector Piece -> ([Piece], [Piece]))
-> IO (Vector Piece) -> IO ([Piece], [Piece])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MVector (PrimState IO) Piece -> IO (Vector Piece)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze IOVector Piece
MVector (PrimState IO) Piece
solved
      [((Int, Int), Int)] -> IO [((Int, Int), Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int, Piece, Piece) -> ((Int, Int), Int))
-> [(Int, Piece, Piece)] -> [((Int, Int), Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(idx :: Int
idx, pa :: Piece
pa, pb :: Piece
pb) -> (Int -> Int -> (Int, Int)
mazeCursor Int
width Int
idx, (Pix -> Pix -> Int) -> (Piece -> Pix) -> Piece -> Piece -> Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Pix -> Pix -> Int
rotations Piece -> Pix
pipe Piece
pa Piece
pb)) ([Int] -> [Piece] -> [Piece] -> [(Int, Piece, Piece)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [0..] [Piece]
as [Piece]
bs))
      where
        rotations :: Pix -> Pix -> Int
rotations from :: Pix
from to :: Pix
to = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Pix
to Pix -> [Pix] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`List.elemIndex` (Pix -> Pix) -> Pix -> [Pix]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Pix -> Pix
rotate 1) Pix
from

-- | Create 'Configuration' from environment variables, create image output directory.
configuration :: MMaze -> IO Configuration
configuration :: MMaze -> IO Configuration
configuration MMaze{String
mazeId :: String
mazeId :: MMaze -> String
mazeId, Int
level :: Int
level :: MMaze -> Int
level} = do
  let String
mazeDir :: String = String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf "lvl%i-%s" Int
level String
mazeId
  String
imageDir :: String <- TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale ("images/%F-%H-%M-%S-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mazeDir String -> ShowS
forall a. [a] -> [a] -> [a]
++ "/") (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  Configuration
conf <- ASetter Configuration Configuration String String
-> String -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Configuration Configuration String String
Lens' Configuration String
cImageDirL String
imageDir (Configuration -> Configuration)
-> IO Configuration -> IO Configuration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO Int) -> Configuration -> IO Configuration
Lens' Configuration Int
cNumCapL (IO Int -> Int -> IO Int
forall a b. a -> b -> a
const IO Int
getNumCapabilities) Configuration
confDefault
  Configuration
conf <- (Setter' Configuration Bool
-> String -> Configuration -> IO Configuration
forall a s. Read a => Setter' s a -> String -> s -> IO s
s Lens' Configuration Bool
Setter' Configuration Bool
cBenchL "bench" (Configuration -> IO Configuration)
-> (Configuration -> IO Configuration)
-> Configuration
-> IO Configuration
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Setter' Configuration Int
-> String -> Configuration -> IO Configuration
forall a s. Read a => Setter' s a -> String -> s -> IO s
s Lens' Configuration Int
Setter' Configuration Int
cDebugL "debug" (Configuration -> IO Configuration)
-> (Configuration -> IO Configuration)
-> Configuration
-> IO Configuration
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Setter' Configuration Int
-> String -> Configuration -> IO Configuration
forall a s. Read a => Setter' s a -> String -> s -> IO s
s Lens' Configuration Int
Setter' Configuration Int
cDebugFreqL "freq" (Configuration -> IO Configuration)
-> (Configuration -> IO Configuration)
-> Configuration
-> IO Configuration
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Setter' Configuration Int
-> String -> Configuration -> IO Configuration
forall a s. Read a => Setter' s a -> String -> s -> IO s
s Lens' Configuration Int
Setter' Configuration Int
cPixSizeL "pix") Configuration
conf
  (Configuration
conf Configuration -> IO () -> IO Configuration
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (IO () -> IO Configuration)
-> (IO () -> IO ()) -> IO () -> IO Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Configuration -> Bool
cBench Configuration
conf) (IO () -> IO Configuration) -> IO () -> IO Configuration
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
imageDir
  where
    s :: Read a => Setter' s a -> String -> s -> IO s
    s :: Setter' s a -> String -> s -> IO s
s setter :: Setter' s a
setter env :: String
env s :: s
s = (\v' :: Maybe String
v' -> ((a -> Identity a) -> s -> Identity s
Setter' s a
setter ((a -> Identity a) -> s -> Identity s) -> (a -> a) -> s -> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (a -> Maybe a -> a
forall a. a -> Maybe a -> a
`fromMaybe` (String -> a
forall a. Read a => String -> a
read (String -> a) -> Maybe String -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
v'))) s
s) (Maybe String -> s) -> IO (Maybe String) -> IO s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
env

-- | Gets passwords for solved levels from the maze server.
pļāpātArWebsocketu :: [Int] -> Bool -> WS.ClientApp ()
pļāpātArWebsocketu :: [Int] -> Bool -> ClientApp ()
pļāpātArWebsocketu levels :: [Int]
levels hide :: Bool
hide conn :: Connection
conn = [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int]
levels Int -> IO ()
solveLevel
  where
    send :: Text -> IO ()
send = Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn
    recv :: IO String
recv = Text -> String
T.unpack (Text -> String) -> IO Text -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn

    solveLevel :: Int -> IO ()
solveLevel level :: Int
level = do
      Text -> IO ()
send (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ "new " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
level)
      IO String
recv

      Text -> IO ()
send (String -> Text
T.pack "map")
      MMaze
maze <- String -> IO MMaze
parse (String -> IO MMaze) -> (Text -> String) -> Text -> IO MMaze
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop 5 (Text -> IO MMaze) -> IO Text -> IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn

      MMaze
solve <- ReaderT Configuration IO MMaze -> Configuration -> IO MMaze
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Int -> MMaze -> MMaze -> ReaderT Configuration IO MMaze
storeBad Int
level MMaze
maze (MMaze -> ReaderT Configuration IO MMaze)
-> ReaderT Configuration IO MMaze -> ReaderT Configuration IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> ReaderT Configuration IO MMaze
solve (MMaze -> ReaderT Configuration IO MMaze)
-> ReaderT Configuration IO MMaze -> ReaderT Configuration IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> ReaderT Configuration IO MMaze
forall (m :: * -> *). MonadIO m => MMaze -> m MMaze
mazeClone MMaze
maze) (Configuration -> IO MMaze) -> IO Configuration -> IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MMaze -> IO Configuration
configuration MMaze
maze
      String -> IO ()
putStr "rotating..." IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      (Text -> IO String) -> [Text] -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\r :: Text
r -> do Text -> IO ()
send Text
r; IO String
recv) ([Text] -> IO [String]) -> IO [Text] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> MMaze -> MMaze -> IO [Text]
rotateStr 10_000 MMaze
maze MMaze
solve

      Text -> IO ()
send (String -> Text
T.pack "verify")
      String -> IO ()
putStrLn (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("\r" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
hide then ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse else ShowS
forall a. a -> a
id) (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
recv

-- | Run solver, likely produce trace output and complain if solve is invalid ('verify').
solveFile :: String -> IO ()
solveFile :: String -> IO ()
solveFile file :: String
file = do
  MMaze
maze <- String -> IO MMaze
parse (String -> IO MMaze) -> IO String -> IO MMaze
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
file
  Configuration
conf <- MMaze -> IO Configuration
configuration MMaze
maze

  (SolverT () -> Configuration -> IO ())
-> Configuration -> SolverT () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SolverT () -> Configuration -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Configuration
conf (SolverT () -> IO ()) -> SolverT () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MMaze
solved <- MMaze -> ReaderT Configuration IO MMaze
solve MMaze
maze
    ReaderT Configuration IO Bool -> SolverT () -> SolverT ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool)
-> ReaderT Configuration IO Bool -> ReaderT Configuration IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MMaze -> ReaderT Configuration IO Bool
verify MMaze
solved) (IO () -> SolverT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn "solution invalid"))

-- | Executable entry point.
main :: IO ()
main :: IO ()
main = Maybe (String, String, [Int]) -> IO ()
run (Maybe (String, String, [Int]) -> IO ())
-> (Maybe String -> Maybe (String, String, [Int]))
-> Maybe String
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, String, [Int]))
-> Maybe String -> Maybe (String, String, [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> (String, String, [Int])
parseUrl (Maybe String -> IO ()) -> IO (Maybe String) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
lookupEnv "websocket"
  where
    run :: Maybe (String, String, [Int]) -> IO ()
run (Just (host :: String
host, path :: String
path, levels :: [Int]
levels)) = do
      Bool
hide <- Maybe Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Maybe Bool -> Bool)
-> (Maybe String -> Maybe Bool) -> Maybe String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> Maybe String -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Bool
forall a. Read a => String -> a
read (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "hide"
      IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String -> ClientApp () -> IO ()
forall a. String -> Int -> String -> ClientApp a -> IO a
WS.runClient String
host 80 String
path ([Int] -> Bool -> ClientApp ()
pļāpātArWebsocketu [Int]
levels Bool
hide)
    run Nothing =
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> IO ()
solveFile ([String] -> IO ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\args :: [String]
args -> if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then ["/dev/stdin"] else [String]
args) ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs

    parseUrl :: String -> (String, String, [Int])
    parseUrl :: String -> (String, String, [Int])
parseUrl s :: String
s =
      case String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn "/" String
s of
        (host :: String
host:rest :: [String]
rest) ->
          case String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn "#" ("/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "/" [String]
rest)) of
            [path :: String
path, levels :: String
levels] -> (String
host, String
path, (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. Read a => String -> a
read (String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn "," String
levels))
            _ -> String -> (String, String, [Int])
forall a. HasCallStack => String -> a
error "usage: websocket=maze.host/1,2,3,4,5,6"
        _ -> String -> (String, String, [Int])
forall a. HasCallStack => String -> a
error "usage: websocket=maze.host/1,2,3,4,5,6"