Skip to content

Commit 6b76b78

Browse files
ilkka-tormailkka-torma
committed
Speed boost
Matching now takes pattern sizes into account. Grids and nonterminals are not yet affected as much as other expressions. Use additional size constraints to further improve speed.
1 parent 0514f2c commit 6b76b78

File tree

1 file changed

+147
-49
lines changed

1 file changed

+147
-49
lines changed

‎Matcher.hs‎

Lines changed: 147 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ import qualified Data.Map.Strict as Map (filter)
77
import Data.Set (member)
88
import Data.Monoid (Any(Any), getAny, mempty)
99
import Data.Maybe (isNothing)
10+
import qualified Data.List.Ordered as Asc (member, isect, union, unionAll, nub)
1011
import Control.Applicative ((<$>), liftA2)
1112
import Control.Monad.Trans.Class (lift)
1213
import Control.Monad.Writer.Lazy (WriterT, tell, listens, runWriterT)
@@ -58,6 +59,12 @@ allMatch xs f = foldr (&?) (return Match) $ f <$> xs
5859
filterMatch :: (Monad m) => [a] -> (a -> m Match) -> m [a]
5960
filterMatch xs p = foldr (\x -> liftA2 (\match -> if match == Match then (x:) else id) $ p x) (return []) xs
6061

62+
-- Sum of two strictly ordered lists
63+
ascSum :: [Int] -> [Int] -> [Int]
64+
ascSum xs = go
65+
where go (y:ys) = Asc.nub . Asc.union [y + x | x <- xs] $ go ys
66+
go [] = []
67+
6168
-- A memoization of matches
6269
type Classification = Map (Rect, D4, Label) Match
6370

@@ -81,6 +88,73 @@ withAnchors f = local $ \con -> con{anchors = f $ anchors con}
8188
logMsg :: String -> Matcher ()
8289
logMsg message = tell (message, mempty)
8390

91+
-- Possible widths and heights of matching rectangles
92+
-- May give false positives, but never false negatives
93+
sizes :: Expr -> Matcher ([Int], [Int])
94+
sizes Border = return ([1], [1])
95+
sizes Edge = do
96+
(maxX, maxY) <- asks size
97+
return ([0..maxX+2], [0..maxY+2])
98+
sizes AnyRect = do
99+
(maxX, maxY) <- asks size
100+
return ([0..maxX+2], [0..maxY+2])
101+
sizes AnyChar = return ([1], [1])
102+
sizes (SomeChar _ _) = return ([1], [1])
103+
sizes (Var _ _) = do
104+
(maxX, maxY) <- asks size
105+
return ([0..maxX+2], [0..maxY+2]) -- TODO: implement
106+
sizes (e1 :> e2) = do
107+
(ws1, hs1) <- sizes e1
108+
(ws2, hs2) <- sizes e2
109+
return (ascSum ws1 ws2, Asc.isect hs1 hs2)
110+
sizes (e1 :^ e2) = do
111+
(ws1, hs1) <- sizes e1
112+
(ws2, hs2) <- sizes e2
113+
return (Asc.isect ws1 ws2, ascSum hs1 hs2)
114+
sizes (e1 :| e2) = do
115+
(ws1, hs1) <- sizes e1
116+
(ws2, hs2) <- sizes e2
117+
return (Asc.nub $ Asc.union ws1 ws2, Asc.nub $ Asc.union hs1 hs2)
118+
sizes (e1 :& e2) = do
119+
(ws1, hs1) <- sizes e1
120+
(ws2, hs2) <- sizes e2
121+
return (Asc.isect ws1 ws2, Asc.isect hs1 hs2)
122+
sizes (e1 :~ e2) = do
123+
(ws1, hs1) <- sizes e1
124+
(ws2, hs2) <- sizes e2
125+
return (Asc.nub $ Asc.union ws1 ws2, Asc.nub $ Asc.union hs1 hs2)
126+
sizes (Not _) = do
127+
(maxX, maxY) <- asks size
128+
return ([0..maxX+2], [0..maxY+2])
129+
sizes (Sized (x1,x2) (y1,y2) e) = do
130+
(maxX, maxY) <- asks size
131+
(ws, hs) <- case e of
132+
Border -> return ([0..maxX+2], [0..maxY+2])
133+
AnyChar -> return ([0..maxX+2], [0..maxY+2])
134+
SomeChar _ _ -> return ([0..maxX+2], [0..maxY+2])
135+
_ -> sizes e
136+
return (Asc.isect ws wRange, Asc.isect hs hRange)
137+
where wRange = case x2 of Just high -> [x1..high]
138+
Nothing -> [x1..]
139+
hRange = case y2 of Just high -> [y1..high]
140+
Nothing -> [y1..]
141+
sizes (Grid (x1,x2) (y1,y2) e) = do
142+
(maxX, maxY) <- asks size
143+
return ([0..maxX+2], [0..maxY+2]) -- TODO: implement
144+
sizes (Count (low, high) e) = do
145+
(maxX, maxY) <- asks size
146+
return ([0..maxX+2], [0..maxY+2])
147+
sizes (InContext e) = do
148+
(maxX, maxY) <- asks size
149+
return ([0..maxX+2], [0..maxY+2])
150+
sizes (Anchor n) = do
151+
anchors <- asks anchors
152+
(maxX, maxY) <- asks size
153+
return $ if length anchors > n
154+
then let (_, _, w, h) = anchors !! n in ([w], [h])
155+
else ([0..maxX+2], [0..maxY+2])
156+
sizes (Fixed e) = sizes e
157+
84158
-- Does the pattern match? Update all sub-rectangles as needed
85159
matches :: Expr -> Rect -> Matcher Match
86160

@@ -126,11 +200,21 @@ matches (Var rot label) rect = do
126200
modify $ insert (rect, rot, label) match
127201
return match
128202

129-
matches (lExp :> rExp) (x, y, w, h) = anyMatch [0..w] $ \i ->
130-
matches lExp (x, y, i, h) &? matches rExp (x+i, y, w-i, h)
131-
132-
matches (dExp :^ uExp) (x, y, w, h) = anyMatch [0..h] $ \j ->
133-
matches dExp (x, y, w, j) &? matches uExp (x, y+j, w, h-j)
203+
matches (lExp :> rExp) (x, y, w, h) = do
204+
(wsl, hsl) <- sizes lExp
205+
(wsr, hsr) <- sizes rExp
206+
let cuts = Asc.isect wsl . reverse . map (w -) $ takeWhile (<= w) wsr
207+
if h `Asc.member` Asc.isect hsl hsr
208+
then anyMatch cuts $ \i -> matches lExp (x, y, i, h) &? matches rExp (x+i, y, w-i, h)
209+
else return NoMatch
210+
211+
matches (tExp :^ bExp) (x, y, w, h) = do
212+
(wsl, hsl) <- sizes tExp
213+
(wsr, hsr) <- sizes bExp
214+
let cuts = Asc.isect hsl . reverse . map (h -) $ takeWhile (<= h) hsl
215+
if w `Asc.member` Asc.isect wsl wsr
216+
then anyMatch cuts $ \j -> matches tExp (x, y, w, j) &? matches bExp (x, y+j, w, h-j)
217+
else return NoMatch
134218

135219
matches (exp1 :| exp2) rect = matches exp1 rect |? matches exp2 rect
136220

@@ -159,59 +243,73 @@ matches (Sized (x1, x2) (y1, y2) expr) r@(x, y, w, h) = do
159243

160244
matches (Grid (0, _) _ _) (_, _, 0, _) = return Match
161245
matches (Grid _ (0, _) _) (_, _, _, 0) = return Match
162-
matches (Grid xr@(x1, x2) yr@(y1, y2) expr) r@(x, y, w, h) = go False False 0 0 [x] [y]
163-
where go :: Bool -> Bool -> Int -> Int -> [Int] -> [Int] -> Matcher Match
164-
go hOverlap vOverlap numH numV hs@(hor:hors) vs@(ver:vers)
165-
| Just n <- x2, numH > n = return NoMatch
166-
| Just n <- y2, numV > n = return NoMatch
167-
| hor == x + w, ver == y + h, hOverlap || x1 <= numH, vOverlap || y1 <= numV = return Match
168-
| otherwise = do
169-
let hMin = case () of
170-
_ | x2 == Just (numH + 1) -> x+w
171-
| isNothing x2 || hOverlap -> hor + 1
172-
| otherwise -> hor
173-
vMin = case () of
174-
_ | y2 == Just (numV + 1) -> y+h
175-
| isNothing y2 || vOverlap -> ver + 1
176-
| otherwise -> ver
177-
hMargin <- filterMatch [hMin .. x+w] $ \newHor ->
178-
allMatch [(hor, v1, newHor-hor, v2-v1) | (v1, v2) <- zip (tail vs) vs] $ matches expr
179-
vMargin <- filterMatch [vMin .. y+h] $ \newVer ->
180-
allMatch [(h1, ver, h2-h1, newVer-ver) | (h1, h2) <- zip (tail hs) hs] $ matches expr
181-
pairs <- filterMatch [(newH, newV) | numH == numV, newH <- hMargin, newV <- vMargin] $ \(newH, newV) ->
182-
matches expr (hor, ver, newH-hor, newV-ver)
183-
anyMatch ([(numH, numV+1, hs, newVer:vs) | numH <= numV, hor == x+w, newVer <- vMargin] ++
184-
[(numH+1, numV, newHor:hs, vs) | numH >= numV, ver == y+h, newHor <- hMargin] ++
185-
[(numH+1, numV+1, newHor:hs, newVer:vs) | (newHor, newVer) <- pairs]) $ \(newNumH, newNumV, newHors, newVers) ->
186-
go (hOverlap || overlap newHors) (vOverlap || overlap newVers) newNumH newNumV newHors newVers
187-
overlap (a:b:c) = a == b
188-
overlap _ = False
189-
190-
matches (Count (low, high) expr) (x, y, w, h) = go 0 0 total allRects
246+
matches (Grid xr@(x1, x2) yr@(y1, y2) expr) r@(x, y, w, h) = do
247+
(ws, hs) <- sizes expr
248+
goWith ws hs
249+
where goWith widths heights = go False False 0 0 [x] [y]
250+
where
251+
go :: Bool -> Bool -> Int -> Int -> [Int] -> [Int] -> Matcher Match
252+
go hOverlap vOverlap numH numV hs@(hor:hors) vs@(ver:vers)
253+
| Just n <- x2, numH > n = return NoMatch
254+
| Just n <- y2, numV > n = return NoMatch
255+
| hor == x + w, ver == y + h, hOverlap || x1 <= numH, vOverlap || y1 <= numV = return Match
256+
| otherwise = do
257+
let hMin = case () of
258+
_ | x2 == Just (numH + 1) -> x+w
259+
| isNothing x2 || hOverlap -> hor + 1
260+
| otherwise -> hor
261+
hCuts = map (hor +) widths `Asc.isect` [hMin .. x+w]
262+
vMin = case () of
263+
_ | y2 == Just (numV + 1) -> y+h
264+
| isNothing y2 || vOverlap -> ver + 1
265+
| otherwise -> ver
266+
vCuts = map (ver +) heights `Asc.isect` [vMin .. y+h]
267+
hMargin <- filterMatch hCuts $ \newHor ->
268+
allMatch [(hor, v1, newHor-hor, v2-v1) | (v1, v2) <- zip (tail vs) vs] $ matches expr
269+
vMargin <- filterMatch vCuts $ \newVer ->
270+
allMatch [(h1, ver, h2-h1, newVer-ver) | (h1, h2) <- zip (tail hs) hs] $ matches expr
271+
pairs <- filterMatch [(newH, newV) | numH == numV, newH <- hMargin, newV <- vMargin] $ \(newH, newV) ->
272+
matches expr (hor, ver, newH-hor, newV-ver)
273+
anyMatch ([(numH, numV+1, hs, newVer:vs) | numH <= numV, hor == x+w, newVer <- vMargin] ++
274+
[(numH+1, numV, newHor:hs, vs) | numH >= numV, ver == y+h, newHor <- hMargin] ++
275+
[(numH+1, numV+1, newHor:hs, newVer:vs) | (newHor, newVer) <- pairs]) $ \(newNumH, newNumV, newHors, newVers) ->
276+
go (hOverlap || overlap newHors) (vOverlap || overlap newVers) newNumH newNumV newHors newVers
277+
overlap (a:b:c) = a == b
278+
overlap _ = False
279+
280+
matches (Count (low, high) expr) (x, y, w, h) = do
281+
(ws, hs) <- sizes expr
282+
let allRects = [(x', y', w', h') |
283+
w' <- Asc.isect ws [0..w], h' <- Asc.isect hs [0..h],
284+
x' <- [x..x+w-w'], y' <- [y..y+h-h']]
285+
total = length allRects
286+
go 0 0 total allRects
191287
where go :: Int -> Int -> Int -> [Rect] -> Matcher Match
192-
go match unk left _ | match >= low, Nothing <- high = return Match
193-
| match >= low, Just n <- high, n >= match + left + unk = return Match
194-
| match + unk + left < low = return NoMatch
195-
| match + left < low = return Unknown
196-
| Just n <- high, match > n = return NoMatch
197-
go match unk left [] = error "Unreachable state."
198-
go match unk left (r:rs) = do
288+
go found unk left _ | found >= low, Nothing <- high = return Match
289+
| found >= low, Just n <- high, n >= found + left + unk = return Match
290+
| found + unk + left < low = return NoMatch
291+
| found + left < low = return Unknown
292+
| Just n <- high, found > n = return NoMatch
293+
go found unk left [] = error "Unreachable state."
294+
go found unk left (r:rs) = do
199295
matchR <- matches expr r
200296
case matchR of
201-
Match -> go (match+1) unk (left-1) rs
202-
NoMatch -> go match unk (left-1) rs
203-
Unknown -> go match (unk+1) (left-1) rs
204-
total = (w+2)*(w+1)*(h+2)*(h+1) `div` 4
205-
allRects = [(x', y', w', h') | w' <- [0..w], h' <- [0..h], x' <- [x..x+w-w'], y' <- [y..y+h-h']]
297+
Match -> go (found+1) unk (left-1) rs
298+
NoMatch -> go found unk (left-1) rs
299+
Unknown -> go found (unk+1) (left-1) rs
206300

207301
matches (InContext expr) r@(x, y, w, h) = do
302+
(ws, hs) <- sizes expr
208303
(maxX', maxY') <- asks size
209304
addBorders <- asks hasBorders
210305
let (minX, maxX, minY, maxY) = if addBorders
211306
then (-1, maxX'+1, -1, maxY'+1)
212-
else ( 0, maxX', 0, maxY')
213-
surrounding = [(x', y', w', h') | x' <- [0..x], y' <- [0..y],
214-
w' <- [w+x-x'..maxX-x'], h' <- [h+y-y'..maxY-y']]
307+
else ( 0, maxX', 0, maxY')
308+
surrounding = [(x', y', w', h') |
309+
w' <- Asc.isect ws [w .. maxX - minX],
310+
h' <- Asc.isect hs [h .. maxY - minY],
311+
x' <- [max minX $ x + w - w' .. min x $ maxX - w'],
312+
y' <- [max minY $ y + h - h' .. min y $ maxY - h']]
215313
withAnchors (r:) $ anyMatch surrounding $ matches expr
216314

217315
matches (Anchor n) r = do

0 commit comments

Comments
 (0)