Find magic numbers for a factorio decimal -> 7 segment display decoder

SevenSegmentSolver.hs

module Main where

import           Control.Monad.Random.Lazy

import           Data.List                 (find)
import           Data.Maybe
import           Debug.Trace
import           Text.Printf

primes :: [Integer]
primes = let
  ps x = test primes where
    lim = floor $ sqrt (fromIntegral  x)
    test (n:ns)
      | n > lim = (traceShowId x) : ps (x+2)
      | 0 == x `rem` n = ps (x+2)
      | otherwise = test ns
  in 2:3:ps 5

segments:: [(Integer, ([Integer], [Integer]))]
segments = [
    (0, ([2,3,5,6,7,8,9,0], [1,4])), -- A
    (1, ([1,2,3,4,7,8,9,0], [5,6])), -- B
    (2, ([1,3,4,5,6,7,8,9,0], [2])), -- C
    (3, ([2,3,5,6,8,0], [1,4,7,9])), -- D
    (4, ([2,6,8,0], [1,3,4,5,7,9])), -- E
    (5, ([4,5,6,8,9,0], [1,2,3,7])), -- F
    (6, ([2,3,4,5,6,8,9], [1,7,0]))  -- G
  ]

segments' :: [([Integer], [Integer])]
segments' = snd <$> segments

data TOp = Lt | Gt deriving (Show)
data FQuad = Quad Integer Integer Integer TOp Integer deriving (Show)

showTripleFor :: ([Integer], [Integer]) -> FQuad -> String
showTripleFor (as, bs) tr@(Quad a b c o d) = s o where
  as' = applyQuad tr <$> as
  bs' = applyQuad tr <$> bs
  s Lt = printf "x = i +2; (%d*x^3 + %d*x + %d) %% %d : %d < %d" a b c d (maximum as') (minimum bs')
  s Gt = printf "x = i +2; (%d*x^3 + %d*x + %d) %% %d : %d > %d" a b c d (minimum as') (maximum bs')

factorioRing :: Integer -> Integer
factorioRing i = ((i + 2147483648) `mod` 4294967296) - 2147483648

applyQuad :: FQuad -> Integer -> Integer
applyQuad (Quad a b c _ d) i = let
  i' = i+2
  a' = factorioRing (i'*i'*i'*a)
  b' = factorioRing (b * i')
  in factorioRing (a' + b' + c) `mod` d

testTriple :: ([Integer], [Integer]) -> FQuad ->  Bool
testTriple (as, bs) tr@(Quad _ _ _ x _) = t x where
  as' = applyQuad tr <$> as
  bs' = applyQuad tr <$> bs
  t Lt = maximum as' < minimum bs'
  t Gt = minimum as' > maximum bs'

seekTriples :: [FQuad]
seekTriples = let
  aLim :: Integer -> [Integer]
  aLim b = takeWhile (< b) [1..]
  potentials :: Integer -> [FQuad]
  potentials b = Quad <$> aLim b <*> aLim b <*> [0] <*> [Lt, Gt] <*> [b]
  filtered :: Integer -> ([Integer], [Integer]) -> Maybe FQuad
  filtered b ls = find (testTriple ls) $ potentials b
  possibilitySpace :: [Maybe [FQuad]]
  possibilitySpace = (\f -> sequence (f <$> segments')) . filtered <$> primes
  in fromJust $ join $ find isJust possibilitySpace


main :: IO ()
main = do
  putStr $ unlines $ zipWith showTripleFor segments' seekTriples