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