trjhtr

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:

1. Roll N six-sided dice, where 1 < N < 21


2. Pick a set of target numbers, depending on the desired effect. For example, [59, 61, 67].


3. Using addition, subtraction, multiplication, and division, cause the numbers shown on the dice to equal one of the target numbers.


4. 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]

1. 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


2. If necessary, then add numbers to reach a target.


3. If necessary, then subtract numbers to reach a target.
   Example: 108 - 5 = 103


4. From the unused remainder of the pool, add and subtract numbers to get 0.


5. 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]