Dice Arithmetic Puzzle Solver in Haskell

Question

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]

• Vogel612: IIUC the so line in sacredGeo isn't quite correct. Shouldn't it be : (concatMap (\x -> [Push x, Sub]) (tail ss)) instead?

Answer 1

The largest code quality issue in this code is the lack of understandability in the names used.
It's also a bit unobvious at first glance that you're representing the operations as a stack-machine, as well as the way you're using the ss.

These two are what made me sit in front of your code for a while, somewhat dumbfounded.
The first issue is resolvable by looking at the names and chosing better ones.

Things like rpnCalc could be evaluateReversePolishNotation (with rpn being renamed to step or go or maybe even apply). ms and mo should contain the word multiply, because that's the operation you are performing there, as and ao should contain add ss and so should contain sub (or even subtract)

Other naming suggestions include changing best to argmax, deleteAll to setminus

---

The second issue is easier to resolve by using comments. Even after reading the code multiple times, I first thought there was a bug in sacredGeo, where so is calculated with Add instead of Sub.
The issue here is that the subtraction itself is hidden within joiner and the order of elements in rto. This makes it hard for humans to grasp the code at first glance.

While RPN is something that computers are really good at, puny humans like me (and possibly you) tend to have trouble following the steps in such a machine. It's very non-obvious how you're evaluating the expression (and rpnCalc seems to only be used as context).

---

As it stands your code only supports "sequential operations". This has benefits and drawbacks, the benefit being the easier implementation of a searching algorithm, the drawback being that you can't make use of "complex operands".

What I mean by that is the following:

The code you have here generates expressions that have a low level of nesting. Basically it creates expressions of the form: \$(m_1 \cdot \ldots \cdot m_j) + (a_1 + \ldots + a_k) - (s_1 + \ldots + s_l) + (0 * \ldots)\$

This incorrectly limits the number of values you can generate (especially with a low number of thrown dice.

I'd recommend trying to find a way to search for an expression tree using a datatype like:

data Expr = 
 Add Expr Expr | 
 Sub Expr Expr | 
 Mul Expr Expr | 
 Div Expr Expr | 
 Value Int 
deriving (Show)

Note that this will make the search algorithm somewhat harder, but it simplifies following the logic of the generated expression :)