-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathghci.hs
203 lines (160 loc) · 8.94 KB
/
ghci.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
-- 2020-01-30-23:37:16
m <- parse =<< readFile "samples/sanity"
p = Progress 0 [Continue (0, 0) 0 True (0, 0) 0 0] m
fmap pipe <$> UV.toList <$> (UV.freeze $ board $ maze p)
putStrLn =<< renderWithPositions p
:l solve
m <- parse " \n \n \n"
partEquate m (1,1)
mazeEquate m (1,1) [(2,2)]
partEquate m (1,1)
partEquate m (2,2)
mazeEquate m (0,0) [(1,1)]
partEquate m (2,2)
-- 2021-02-22-20:19:16
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
:l solve
renderImage' "ghci" =<< initProgress =<< parse =<< readFile "samples/5-1"
q <- reconnectComponents =<< islandize =<< solve' (-1) True =<< initProgress =<< parse =<< readFile "samples/5-1"
writeFile "out" . LBS.unpack . Aeson.encode . toJSON . (\(Components' c) -> Map.mapKeys show c) . components $ q
renderImage' "ghci" q
nub . map (area . snd) . Map.toList . continues . fst $ q
preview $ (mkGraph [(1, "")] [] :: Gr String String)
import qualified Data.List as L
L.sort . map snd . Map.toList <$> islandize' q
-- unique island sizes (slightly smaller number than the number of islands, but close)
-- [6,8,10,11,12,14,16,19,20,21,23,24,25,27,37,45,65,66,76,96,117,226,232]
-- [6,6,6,6,6,6,6,8,8,8,8,8,10,10,10,10,11,12,14,16,19,20,21,23,24,24,25,27,37,37,45,65,66,76,96,117,226,232]
map (uncurry (+) . cursor . snd) . Map.toList $ priority q
-- number of unique cursors
-- [68,69,70,71,72,73,74,75,76,77,...
islandize' :: Progress -> IO (Map Cursor Int)
islandize' p@Progress{maze, priority} =
fmap snd . foldrM acc (Set.empty, Map.empty) $ map (cursor . snd) . Map.toList $ priority
where
acc cursor t@(visited, m) =
if (cursor `Set.member` visited)
then pure t
else do
(more, _inhabitants) <- fillSize (fillNextSolved Map.empty) maze cursor
pure (visited `Set.union` more, Map.insert cursor (Set.size more) m)
fillNextSolved :: Continues -> FillNext (Set Cursor)
fillNextSolved continues _ cur _ deltasWall = do
when (cur `Map.member` continues) $ State.modify (Set.insert cur)
pure . map (cursorDelta cur . snd) . filter (\(Piece{pipe, solved}, _) -> pipe /= 0 && not solved) $ deltasWall
uniq = foldr uniq' [] where uniq' x acc = x : dropWhile (== x) acc
(iter q, depth q, length (space q))
uniq (map length (space q))
length $ filter (== 1) (map length (space q))
filter ((>= 1) . snd) (zip [0..] $ map length (space q))
-- 2021-02-27-11:34:52
import Graphics.Image.ColorSpace (toWord8Px)
import Graphics.Image.Interface (thaw, MImage, freeze, write)
import Graphics.Image (writeImage, makeImageR, Pixel(..), toPixelRGB, VS(..), RGB, Writable(..), VU(..), Image)
import Data.Word
let gc = makeImageR VS (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j)))
let grad_gray = makeImageR VU (200, 200) (\(i, j) -> PixelY (fromIntegral i) / 200 * (fromIntegral j) / 200)
let grad_color = makeImageR VU (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j))) / 400
writeImage "images/grad_color.png" grad_color
writeImage "images/x.png" $ makeImageR VU (200, 200) (\(i, j) -> toPixelRGB $ PixelHSI 0 1 (fromIntegral (i+j)/400))
-- 2021-03-14-18:20:50
import Control.Lens.Internal.FieldTH (makeFieldOptics, LensRules(..))
import Language.Haskell.TH.Syntax (mkName, nameBase)
import Control.Lens.TH (DefName(..), lensRules)
suffixLNamer = (\_ _ -> (:[]) . TopName . mkName . (++ "L") . nameBase)
:t makeFieldOptics lensRules { _fieldToDef = suffixLNamer }
-- 2021-05-01-16:53:57
import Numeric (showIntAtBase)
import Data.Char (intToDigit)
:l Pipemaze
p <- initProgress =<< parse =<< readFile "samples/3"
(Map.! (0, 1)) $ continues p
showBin . flip Bit.shiftR choicesInvalid . initChoices . (V.! 8) <$> V.freeze (board (maze p))
flip Bit.shiftR choicesCount . choices . snd <$> Map.toList (continues p)
showBin = flip (showIntAtBase 2 intToDigit) ""
-- V.map (showBin . flip Bit.shiftR choicesInvalid . initChoices) <$> V.freeze (board (maze p))
showBin . flip Bit.shiftR choicesInvalid . initChoices . V.head <$> V.freeze (board (maze p))
-- 2021-05-06-21:33:38
p <- initProgress =<< parse =<< readFile "samples/3"
p <- fmap fromJust (solve' (-1) True p)
render . maze . fromJust =<< solve' (-1) False =<< (set mazeL <$> mazeClone (maze p) <*> pure p)
import Control.Concurrent (threadDelay)
:l Pipemaze
-- progressClone :: Progress -> IO Progress
progressClone = mazeL (boardL MV.clone) :: Progress -> IO Progress
progressRender = (\p -> putStrLn "\x1b[H\x1b[2K" >> render (maze p))
showSpace = filter (not . null . fst) . flip zip [0..] . fmap (fmap fst) . space
deterministic = Constraints (-1) True Nothing
p_ <- initProgress =<< parse =<< readFile "samples/3"
p_ <- fmap fromJust (solve' deterministic p_)
-- progressRender p_
-- islandsSolutions p_ . fst =<< islands p_
-- islandsSolutions p_ . sortOn (iSize) . fst =<< islands p_
-- traverse print . map (_2 %~ (map fst)) =<< (islandsSolutions p_ . sortOn (iSize) . fst =<< islands p_)
traverse print =<< (islandsSolutions p_ . sortOn (iSize) . fst =<< islands p_)
-- [(3,1),(4,2),(4,2),(8,1),(8,2),(9,2),(17,1),(24,1),(38,2),(82,8),(83,2),(294,72)]
-- iSize . head . sortOn (iSize) . fst <$> islands p_
islandsSolutions p_ . take 1 . sortOn (iSize) . fst =<< islands p_
ps <- iterateMaybeM 100 (\p -> fmap (mfilter progressSolved) . solve' (2500 * 10) False =<< progressClone p) p_
traverse_ ((>> threadDelay 1000000) . progressRender ) ps
ic = Constraints 1000 False (Just iBounds)
ip i p = progressClone =<< prioritizeContinues p { space = [], unwinds = [], priority = IntMap.empty, continues = IntMap.empty }
islandSolutions ic c p = iterateMaybeM 100 (fmap (mfilter progressSolved) . solve' (ic i)) =<< ip i p
map (length . iBounds) . fst <$> islands p_
traverse (fmap length . solutions) p_ . fst =<< islands p_
-- traverse print . fmap (take 2 . showSpace) $ ps
-- length . nubOrd . fmap (filter (not . null . fst) . flip zip [0..] . fmap (fmap fst) . space) $ ps
s n p = foldrM id p . replicate n $ (\p -> fromJust <$> solve' 300000 False p)
ss n p = s n =<< progressClone p
progressRender =<< ss 3 p_
s n p = foldrM id p . replicate n $ (\p -> fmap fromJust . solve' 300000 False =<< progressClone p)
ss n p = s n =<< progressClone p
progressRender =<< ss 3 p_
-- 2021-05-09-11:05:00
-- bug: backtracking doesn't reuse previous' solve's maze
progressRender =<< fmap fromJust . solve' 5000 False =<< progressClone =<< pure p_
progressRender =<< fmap fromJust . solve' 5000 False =<< progressClone =<< fmap fromJust . solve' 5000 False =<< progressClone =<< pure p_
progressRender =<< fmap fromJust . solve' 5000 False =<< (mazeL (boardL (\b -> MV.clone b)) =<< fmap fromJust . solve' 5000 False =<< progressClone =<< pure p_)
progressRender =<< fmap fromJust . solve' 5000 False =<< mazeL (boardL (\b -> MV.clone b >> pure b)) =<< fmap fromJust . solve' 5000 False =<< progressClone =<< pure p_
p <- fmap fromJust . solve' 25000 False =<< progressClone =<< pure p_
rs = set spaceL []
(rs p ==) . rs <$> progressClone p
fmap (take 2 . showSpace . fromJust) . solve' (-1) False =<< fmap fromJust . solve' (-1) False =<< fmap Just (progressClone p_)
fmap depth . fmap fromJust . solve' (-1) False =<< progressClone p_
fmap depth . fmap fromJust . solve' (-1) False =<< fmap fromJust . solve' (-1) False =<< progressClone p_
λ: f = pure . fmap (+1) . mfilter (\a -> mod a 11 /= 3) . Just
λ: iterateMaybeM 1000 f 4
[5,6,7,8,9,10,11,12,13,14]
λ: iterateMaybeM 1000 f 7
[8,9,10,11,12,13,14]
-- 2021-05-22-17:06:30
l = map Set.fromList [[1], [2,1], [1,2]]
map head . groupSortOn id $ l
-- 2021-05-17-19:08:37
progressClone = mazeL (boardL MV.clone) :: Progress -> IO Progress
-- fmap fromJust (solve' (Constraints 1 False Nothing) =<< progressClone p_)
progressRender p_
:l Pipemaze
showSpace = filter (not . null . fst) . flip zip [0..] . fmap (fmap fst) . space
p_ <- initProgress =<< parse =<< readFile "samples/3"
p_ <- componentRecalc True . fromJust =<< (solve' deterministic p_)
is <- fmap (sortOn length) . traverse (islandChoices p_) . fst =<< (islands p_)
bigIsleI <- last . sortOn iSize . fst <$> islands p_
bigIsle = last (sortOn length is) -- equivalent solutions grops
() <$ for is print
import Control.Concurrent (threadDelay)
progressRender = (\p -> putStrLn "\x1b[H\x1b[2K" >> render (maze p))
progressRenders = traverse_ ((>> threadDelay 1000000) . progressRender)
progressRenders (head (map snd bigIsle)) -- plot all equivalent island solves
progressRenders (map (head . snd) bigIsle) -- plot all distinct island solves
progressRender p_
progressRender (head (map (head . snd) bigIsle))
mazeCursor 25 . head . sort . map cursor . iConts $ bigIsleI
() <$ for (map (map (nubOrdOn depth . snd)) is) print
() <$ for (map (map (map depth . nubOrdOn depth . snd)) is) print
(depth p_ ==) <$> (length . V.filter solved <$> V.freeze (board (maze p_)))
fmap (map (map depth . nubOrdOn depth . snd)) . islandChoices p_ $ bigIsleI
fmap (map (map depth . snd)) . islandChoices p_ $ bigIsleI
traverse print =<< (islandChoices p_ $ bigIsleI)
print (depth, stop, ' ', depth == size - 1, life, life == 0, unbounded)