Use a newtype wrapper for sets of factors

[BlackCapCoder]

The first half of Fractran.hs is implementing semiring functionality for IntMap, which is a map from prime factors to exponents. Perhaps we should isolate this into into its own file for the sake of readability?

-- Factored.hs

import Data.Semiring
import Data.Map.Strict qualified as M
import Math.NumberTheory.Primes

newtype Factored i
      = Factored { factors :: M.Map (Prime i) Word }
  deriving
    ( Show, Eq, Ord
    )

factored =
  Factored . M.fromList . factorise

unfactored =
  factorBack . M.toList . factors


instance (Ord i, Semiring i, UniqueFactorisation i) => Semiring (Factored i)
  where

  one  = Factored M.empty
  zero = one

  plus a b =
    factored $ unfactored a + unfactored b

  times (Factored a) (Factored b) =
    Factored $ M.unionWith (+) a b

instance (Ord i, Semiring i, UniqueFactorisation i) => GcdDomain (Factored i)
  where

  coprime (Factored a) (Factored b) =
    M.disjoint a b

  gcd (Factored a) (Factored b) =
    Factored $ M.intersectionWith min a b

  divide (Factored a) (Factored b) =
    [ Factored
    $ M.differenceWith (\a b -> a-b <$ guard (a>b)) a b
    | M.isSubmapOfBy (<=) b a
    ]

Here's an old/new comparison of a function that uses the instances.

fracOpt :: _ => [Ratio i] -> Factored i -> [Factored i]
fracOpt fracs = eval ifs
  where
    ifs =
      zip [0..] fmaps

    fmaps =
      [(factored a, factored b) | a:%b <- fracs]

    eval fs n = do
      (i,p):_ <- [[(i,x*r) | (i,(x,divide n->Just r)) <- fs]]
      p : eval (opts ! i) p

    opts =
      listArray (0, length fmaps - 1) $
        zipWith3 (\a b c -> f a b ++ c)
          fmaps
          (inits ifs)
          (init $ tails ifs)

    f (num,_) pre =
      [ p | p@(_,(_,x)) <- pre, not $ coprime num x ]

-- vs.

optArr :: [(IntMap, IntMap)] -> Array Int [(Int, (IntMap, IntMap))]
optArr fs = listArray (0, length fs - 1) opts where
  ifs = zip [0..] fs
  opts = [opt i f | (i,f) <- ifs]
  opt i f = let (pre,post) = splitAt i ifs in (preOpt f pre ++ post)
  preOpt (num, _) pre = (filter (couldPre num . snd . snd) pre)
  couldPre a b = not . M.null $ M.intersection a b
  msg = unlines $ [show (i, map fst o) | (i,o)<-zip [0..] opts]

fracOpt :: [Rational] -> Integer -> [IntMap]
fracOpt fracs init = fracOpt' fracs $ facmap init
fracOpt' fracs init = eval ifs $ validateIM init where
  fmaps = [(facmap $ numerator f, facmap $ denominator f) | f<-fracs]
  ifs = (zip [0..] fmaps) :: [(Int, (IntMap, IntMap))]
  opts = optArr fmaps
  match fs n = (find (compat n . snd) fs) :: Maybe (Int, (IntMap, IntMap))
  eval fs n = maybe [] (next . times' n) $ match fs n
  times' n (i, f) = (i, times n f)
  next (i, p) = p : (eval :: [(Int, (IntMap, IntMap))] -> IntMap -> [IntMap]) (opts ! i) p

[pimlu]

Thanks, these are good ideas. I might take a crack at this in a week or two, or PRs are welcome haha.