138 lines
6.2 KiB
Haskell
138 lines
6.2 KiB
Haskell
import Math.GenBase.Base (Fp (..), frombasef, zipAdd)
|
|
import Math.GenBase.Recur (Literal (..))
|
|
import Data.List (unfoldr)
|
|
|
|
zipUp = foldl (flip (:))
|
|
|
|
--expand a 1 rightward
|
|
expand rule fp@(Fp (x:xs) a) = expand' [] xs
|
|
where expand' zs [] = fp
|
|
expand' zs (y:ys) | y > 0 = flip Fp a $ (x:) $ zipUp (y-1:zipAdd ys rule) zs
|
|
| otherwise = expand' (y:zs) ys
|
|
|
|
ruleMatch _ [] xs = Just xs
|
|
ruleMatch True _ [x] = Nothing
|
|
ruleMatch _ _ [] = Nothing --list consumed before rule
|
|
ruleMatch a (r:rs) (x:xs) | x < r = Nothing
|
|
| otherwise = fmap (x-r:) $ ruleMatch a rs xs
|
|
|
|
--convert `from` something using the `rule` to `replace`
|
|
--`r` controls whether to ignore the last element of `xs`
|
|
--`Right` if no replacement took place; otherwise left
|
|
convert rule replace r from@(Fp xs x)
|
|
| rule == fVect replace = Right from
|
|
| otherwise = convert' [] xs
|
|
where convert' zs [] = Right from
|
|
convert' zs as@(a:aas) = case ruleMatch r rule as of
|
|
Nothing -> convert' (a:zs) aas
|
|
Just sum -> case null zs of
|
|
--the rule matched in the first position
|
|
True -> Left $ replace + (Fp sum x)
|
|
_ -> Left $ flip Fp x $ zipUp (zipAdd frac sum) $ zipAdd zs $ reverse integ
|
|
(integ, frac) = (\(Fp as a) -> splitAt a as) replace
|
|
|
|
convert' = (((either id id.).).) . convert
|
|
|
|
--generate recursive expansions from expanding/contracting a polynomial
|
|
tryExpand rule first = map (contract' False) $ unfoldr (Just . dupe . go) $ Fp first 0
|
|
where --first pass: expand 1's rightward
|
|
dupe a = (a,a)
|
|
--check for occurrences of the string we started with; apply recursively
|
|
selfcheck fp = convert' first fp False fp
|
|
contract' = convert' rule $ Fp [1] 1
|
|
go = expand rule . selfcheck . contract' True
|
|
|
|
spacing = (1:) . spacing' 0
|
|
where spacing' _ 0 = [1]
|
|
spacing' x n = x:spacing' x (n-1)
|
|
isSpacing = (<=1) . length . dropWhile (==0) . tail . fVect
|
|
|
|
zeroRuns = zrs' [] 0
|
|
where zrs' ys n [] = ys
|
|
zrs' ys n (x:xs) | x == 0 = zrs' ys (n+1) xs
|
|
| otherwise = zrs' (n:ys) 0 xs
|
|
validSpacing n = (>n) . minimum . init . zeroRuns
|
|
|
|
--mutually recurse all spacings up to n, where `Fp (spacing n) 0 = Fp [1] 1`
|
|
|
|
--logic:
|
|
--start with list of spacings less than n
|
|
--for each current string representing spacing:
|
|
-- if maximally spaced, STOP
|
|
-- convert spacings, going from largest to smallest that are a substring in current (Left)
|
|
-- if no such spacing is found, test if this is a maximally spaced (Right)
|
|
-- otherwise, expand a 1
|
|
--
|
|
--PROBLEMS: incapable of "looking past" a 1:bigrule, and gets caught in a 2-cycle
|
|
start n = map (tail . map (\(_,_,x) -> x)) $ iterate (\x -> map (advance $ each x) x) spacings
|
|
where --generate all spacings
|
|
bigrule = spacing n
|
|
zwei = (True, \x -> convert [2] x False, Fp (1:bigrule) 0)
|
|
eins = (True, \x -> convert bigrule x True, Fp [1] 1)
|
|
spacings = let builder = (\s -> (False, \x -> convert s x False, Fp s 0)) . spacing
|
|
in zwei:eins:map builder [n-1,n-2..0]
|
|
each = map (\(_,r,s) -> r s)
|
|
|
|
hasMatch rule [] = False
|
|
hasMatch rule xs = case ruleMatch False rule xs of
|
|
Nothing -> hasMatch rule $ tail xs
|
|
Just _ -> True
|
|
|
|
advance current (p, rule, state)
|
|
| p = (p, rule, state) --maximally spaced
|
|
| otherwise = either repackage testSpace foldRules
|
|
--if any of these /succeeds/ then it's a Left and we exit early
|
|
where foldRules = foldl (>>=) (Right state) $ advancement current
|
|
advancement = case hasMatch (1:bigrule) $ fVect state of
|
|
True -> id --no match, goahead
|
|
_ -> id
|
|
repackage fp = (p, rule, fp) --repackage any rules applied
|
|
--otherwise no spacing was found
|
|
testSpace fp | valid fp = (True, rule, fp)
|
|
| otherwise = (False, rule, expand bigrule fp)
|
|
valid = validSpacing n . fVect
|
|
|
|
--greedily search through the heads of the expansions, and see if
|
|
--one expansion can be used in another
|
|
start' n = map (map snd) $ iterate (\r -> map (continue r) r) $ map builder [0..n]
|
|
where --generate all spacings
|
|
bigrule = spacing n
|
|
--i COULD use a map, but nah
|
|
builder m | n == m = (True, Fp [1] 1)
|
|
| otherwise = (False, Fp (spacing m) 0)
|
|
|
|
continue r (p,y) | p = (True, y)
|
|
| otherwise = ruleSearch r y
|
|
|
|
--lazy `(>m) . len`
|
|
lenMore m _ [] = False
|
|
lenMore m x (_:xs) | x < m = lenMore m (x+1) xs
|
|
| otherwise = True
|
|
|
|
ruleSearch rules fp@(Fp fs f) = rS' [] 0 fs
|
|
where fpf = flip Fp f
|
|
rS' zs m [] = (True, fp)
|
|
rS' zs m (x:xs)
|
|
| x == 0 = rS' (x:zs) (m+1) xs
|
|
| x > 1 = (False, expand 1 $ map (*(x-1)) bigrule)
|
|
| m > n || null zs = rS' (x:zs) 0 xs
|
|
| null match = if worthwhile
|
|
then (False, Fp (continue (2+r) rep) (f+r))
|
|
else (False, expand (x-1) bigrule)
|
|
| otherwise = (False, fpf $ zipUp (continue 2 frac) $ zipAdd match $ reverse integ)
|
|
where match = drop (m+1) zs
|
|
(Fp rep r) = snd $ rules !! m
|
|
(integ, frac) = splitAt r rep
|
|
worthwhile = not (null integ) || lenMore (m+2) 0 frac
|
|
continue c = zipAdd $ (replicate (m+c) 0) ++ xs
|
|
expand e = fpf . flip zipUp zs . (e:) . zipAdd xs
|
|
|
|
--extract expansions for a single spacing `m` from `start n`
|
|
spacings n m = map (!!(n-m)) $ start n
|
|
--extract expansions for a single spacing `m` from `start' n`
|
|
spacings' n m = map (!!m) $ start' n
|
|
|
|
--sanity check: use approximate root to interpret expansion
|
|
sanityCheck f n m = let base = frombasef $ Literal $ spacing n
|
|
in map (\x -> (x, base x)) $ f n m
|