As a learning exercise, I decided to implement an automatic solver for the Sacred Geometry feat from Pathfinder (a TTRPG). The requirements to use the feat are:
- Roll N six-sided dice, where 1 < N < 21
- Pick a set of target numbers, depending on the desired effect. For example, [59, 61, 67].
- Using addition, subtraction, multiplication, and division, cause the numbers shown on the dice to equal one of the target numbers.
- ALL the dice rolled must be used.
While a brute-force approach would be simpler, it could get quite slow for large amounts of dice, and I thought an algorithm would be more interesting, so here's the one I'm using:
Example: Pool = [5, 4, 6, 5, 2, 3, 2, 3, 3, 1, 3, 5, 6], Targets = [101, 103, 107]
- Multiply numbers from the pool, always picking the one that gets closest to any target, until multiplying any more would take you farther from the targets.
Example: 6 x 6 x 3 = 108
- If necessary, then add numbers to reach a target.
- If necessary, then subtract numbers to reach a target.
Example: 108 - 5 = 103
- From the unused remainder of the pool, add and subtract numbers to get 0.
- Multiply all remaining numbers by the zero to cancel them out.
The code appears to work correctly (it would fail in edge cases like "all 1s", but that's fine for my purposes), but I feel like there's probably a more elegant way to do it, and I'm not sure how well my organization/naming fits the Haskell style.
Also, if there's a significantly better (non brute force) algorithm, I'm not married to this one.
import Data.List data Op = Add | Sub | Mul | Div | Push Int deriving (Show) rpnCalc :: [Op] -> Int rpnCalc seq = head (foldl rpn  seq) where rpn (a:b:rest) Add = (a + b):rest rpn (a:b:rest) Sub = (a - b):rest rpn (a:b:rest) Mul = (a * b):rest rpn (a:b:rest) Div = (quot a b):rest rpn rest (Push a) = a:rest best :: (Ord b) => [a] -> (a->b) -> a best [x] _ = x best (x:xs) f = let y = (best xs f) in if (f x) > (f y) then x else y deleteAll :: (Eq a) => [a] -> [a] -> [a] deleteAll list  = list deleteAll list (x:xs) = deleteAll (delete x list) xs minDist :: (Ord a, Num a) => a -> [a] -> a minDist n targets = minimum $ map (abs . (n-)) targets pickItems :: (Ord a, Num a) => [a] -> [a] -> (a->a->a) -> a -> [a] pickItems pool goals op acc | (null pool) =  | (minDist (acc `op` pick) goals) >= (minDist acc goals) =  | otherwise = pick : (pickItems (delete pick pool) goals op (acc `op` pick)) where pick = best pool (\x -> -(minDist (acc `op` x) goals)) reachTarget :: (Ord a, Num a) => [a] -> [a] -> ([a], [a], [a]) reachTarget pool goals = (ms, as, ss) where ms = pickItems pool goals (*) 1 r1 = foldl (*) 1 ms p1 = deleteAll pool ms g1 = map (\x -> x-r1) goals as = pickItems p1 g1 (+) 0 r2 = foldl (+) 0 as p2 = deleteAll p1 as g2 = map (\x -> x-r2) g1 ss = pickItems p2 g2 (-) 0 zeroPool :: [Int] -> [Op] zeroPool pool = let solution = solve pool 0 in if null solution then  else let unused = deleteAll pool [v | Push v <- solution] in solution ++ (concatMap (\x -> [Push x, Mul]) unused) where solve :: [Int] -> Int -> [Op] solve [x] goal = if x == goal then [Push x] else  solve (x:xs) goal | x == goal = [Push x] | x < goal = let try = (solve xs (goal - x)) in if null try then solve xs goal else try ++ [Push x, Add] | x > goal = let try = (solve xs (x - goal)) in if null try then solve xs goal else try ++ [Push x, Sub] sacredGeo :: [Int] -> [Int] -> [Op] sacredGeo pool goals = rto where (ms, as, ss) = reachTarget pool goals mo = (Push (head ms)) : (concatMap (\x -> [Push x, Mul]) (tail ms)) ao = if (null as) then  else (Push (head as)) : (concatMap (\x -> [Push x, Add]) (tail as)) so = if (null ss) then  else (Push (head ss)) : (concatMap (\x -> [Push x, Add]) (tail ss)) remaining = deleteAll pool (ms ++ as ++ ss) zo = zeroPool remaining joiner = (if (null ao) then  else [Add]) ++ (if (null so) then  else [Sub]) rto = so ++ mo ++ ao ++ joiner ++ zo ++ [Add]