|
| 1 | +module PalindromeProducts exposing (largest, smallest) |
| 2 | + |
| 3 | +import Array exposing (Array) |
| 4 | +import Set |
| 5 | + |
| 6 | + |
| 7 | +type alias PalindromeProduct = |
| 8 | + { value : Int |
| 9 | + , factors : List ( Int, Int ) |
| 10 | + } |
| 11 | + |
| 12 | + |
| 13 | +smallest : Int -> Int -> Result String (Maybe PalindromeProduct) |
| 14 | +smallest min max = |
| 15 | + if min > max then |
| 16 | + Err "min must be <= max" |
| 17 | + |
| 18 | + else |
| 19 | + let |
| 20 | + initQueue = |
| 21 | + new (\( i, j ) -> i * j) (<=) |
| 22 | + |> insert ( min, min ) |
| 23 | + |
| 24 | + traverse queue visited = |
| 25 | + case pop queue of |
| 26 | + Nothing -> |
| 27 | + Ok Nothing |
| 28 | + |
| 29 | + Just ( ( i, j ), product, poppedQueue ) -> |
| 30 | + if isPalindrome product then |
| 31 | + popUntilDifferent { value = product, factors = [ ( i, j ) ] } poppedQueue |
| 32 | + |
| 33 | + else if j > max then |
| 34 | + traverse poppedQueue visited |
| 35 | + |
| 36 | + else |
| 37 | + let |
| 38 | + newVisited = |
| 39 | + visited |> Set.insert ( i, j + 1 ) |> Set.insert ( i + 1, j + 1 ) |
| 40 | + |
| 41 | + newQueue = |
| 42 | + [ ( i, j + 1 ), ( i + 1, j + 1 ) ] |> List.filter (\pair -> not (Set.member pair visited)) |> List.foldl insert poppedQueue |
| 43 | + in |
| 44 | + traverse newQueue newVisited |
| 45 | + in |
| 46 | + traverse initQueue Set.empty |
| 47 | + |
| 48 | + |
| 49 | +largest : Int -> Int -> Result String (Maybe PalindromeProduct) |
| 50 | +largest min max = |
| 51 | + if min > max then |
| 52 | + Err "min must be <= max" |
| 53 | + |
| 54 | + else |
| 55 | + let |
| 56 | + initQueue = |
| 57 | + new (\( i, j ) -> i * j) (>) |
| 58 | + |> insert ( max, max ) |
| 59 | + |
| 60 | + traverse queue visited = |
| 61 | + case pop queue of |
| 62 | + Nothing -> |
| 63 | + Ok Nothing |
| 64 | + |
| 65 | + Just ( ( i, j ), product, poppedQueue ) -> |
| 66 | + if isPalindrome product then |
| 67 | + popUntilDifferent { value = product, factors = [ ( i, j ) ] } poppedQueue |
| 68 | + |
| 69 | + else if i < min then |
| 70 | + traverse poppedQueue visited |
| 71 | + |
| 72 | + else |
| 73 | + let |
| 74 | + neighbors = |
| 75 | + [ ( i - 1, j ), ( i - 1, j - 1 ) ] |
| 76 | + |
| 77 | + newVisited = |
| 78 | + List.foldl Set.insert visited neighbors |
| 79 | + |
| 80 | + newQueue = |
| 81 | + neighbors |
| 82 | + |> List.filter (\pair -> not (Set.member pair visited)) |
| 83 | + |> List.foldl insert poppedQueue |
| 84 | + in |
| 85 | + traverse newQueue newVisited |
| 86 | + in |
| 87 | + traverse initQueue Set.empty |
| 88 | + |
| 89 | + |
| 90 | +isPalindrome : Int -> Bool |
| 91 | +isPalindrome n = |
| 92 | + let |
| 93 | + string = |
| 94 | + String.fromInt n |
| 95 | + in |
| 96 | + string == String.reverse string |
| 97 | + |
| 98 | + |
| 99 | +popUntilDifferent : PalindromeProduct -> PriorityQueue ( Int, Int ) -> Result String (Maybe PalindromeProduct) |
| 100 | +popUntilDifferent product queue = |
| 101 | + case pop queue of |
| 102 | + Nothing -> |
| 103 | + Ok (Just { product | factors = List.sort product.factors }) |
| 104 | + |
| 105 | + Just ( pair, value, newQueue ) -> |
| 106 | + if value == product.value then |
| 107 | + popUntilDifferent { product | factors = pair :: product.factors } newQueue |
| 108 | + |
| 109 | + else |
| 110 | + Ok (Just { product | factors = List.sort product.factors }) |
| 111 | + |
| 112 | + |
| 113 | + |
| 114 | +-- Priority Queue |
| 115 | + |
| 116 | + |
| 117 | +type alias PriorityQueue a = |
| 118 | + { leq : Int -> Int -> Bool |
| 119 | + , toPriority : a -> Int |
| 120 | + , heap : Heap a |
| 121 | + } |
| 122 | + |
| 123 | + |
| 124 | +type alias Heap a = |
| 125 | + Array ( a, Int ) |
| 126 | + |
| 127 | + |
| 128 | +new : (a -> Int) -> (Int -> Int -> Bool) -> PriorityQueue a |
| 129 | +new toPriority leq = |
| 130 | + PriorityQueue leq toPriority Array.empty |
| 131 | + |
| 132 | + |
| 133 | +insert : a -> PriorityQueue a -> PriorityQueue a |
| 134 | +insert a ({ leq, toPriority, heap } as queue) = |
| 135 | + { queue | heap = insertHeap leq a (toPriority a) heap } |
| 136 | + |
| 137 | + |
| 138 | +insertHeap : (Int -> Int -> Bool) -> a -> Int -> Heap a -> Heap a |
| 139 | +insertHeap leq a p heap = |
| 140 | + bubbleUp leq (Array.length heap) (Array.push ( a, p ) heap) |
| 141 | + |
| 142 | + |
| 143 | +bubbleUp : (Int -> Int -> Bool) -> Int -> Heap a -> Heap a |
| 144 | +bubbleUp leq index heap = |
| 145 | + let |
| 146 | + parentIndex = |
| 147 | + (index - 1) // 2 |
| 148 | + in |
| 149 | + case ( Array.get index heap, Array.get parentIndex heap ) of |
| 150 | + ( Just ( newA, newP ), Just ( parentA, parentP ) ) -> |
| 151 | + if index > 0 && leq newP parentP then |
| 152 | + bubbleUp leq |
| 153 | + parentIndex |
| 154 | + (heap |
| 155 | + |> Array.set index ( parentA, parentP ) |
| 156 | + |> Array.set parentIndex ( newA, newP ) |
| 157 | + ) |
| 158 | + |
| 159 | + else |
| 160 | + heap |
| 161 | + |
| 162 | + _ -> |
| 163 | + heap |
| 164 | + |
| 165 | + |
| 166 | +pop : PriorityQueue a -> Maybe ( a, Int, PriorityQueue a ) |
| 167 | +pop ({ leq, heap } as queue) = |
| 168 | + case Array.get 0 heap of |
| 169 | + Nothing -> |
| 170 | + Nothing |
| 171 | + |
| 172 | + Just ( aTop, pTop ) -> |
| 173 | + let |
| 174 | + newHeap = |
| 175 | + case Array.get (Array.length heap - 1) heap of |
| 176 | + Nothing -> |
| 177 | + heap |
| 178 | + |
| 179 | + Just ( a, p ) -> |
| 180 | + heap |
| 181 | + |> Array.set 0 ( a, p ) |
| 182 | + |> Array.slice 0 (Array.length heap - 1) |
| 183 | + |> bubbleDown leq 0 |
| 184 | + in |
| 185 | + Just ( aTop, pTop, { queue | heap = newHeap } ) |
| 186 | + |
| 187 | + |
| 188 | +bubbleDown : (Int -> Int -> Bool) -> Int -> Heap a -> Heap a |
| 189 | +bubbleDown leq index heap = |
| 190 | + let |
| 191 | + leftIndex = |
| 192 | + index * 2 + 1 |
| 193 | + |
| 194 | + rightIndex = |
| 195 | + index * 2 + 2 |
| 196 | + in |
| 197 | + case ( Array.get index heap, Array.get leftIndex heap, Array.get rightIndex heap ) of |
| 198 | + ( Just ( a, p ), Just ( leftA, leftP ), Nothing ) -> |
| 199 | + if leq p leftP then |
| 200 | + heap |
| 201 | + |
| 202 | + else |
| 203 | + heap |> Array.set index ( leftA, leftP ) |> Array.set leftIndex ( a, p ) |
| 204 | + |
| 205 | + ( Just ( a, p ), Just ( leftA, leftP ), Just ( rightA, rightP ) ) -> |
| 206 | + if leq p leftP && leq p rightP then |
| 207 | + heap |
| 208 | + |
| 209 | + else if leq leftP rightP then |
| 210 | + bubbleDown leq leftIndex (heap |> Array.set index ( leftA, leftP ) |> Array.set leftIndex ( a, p )) |
| 211 | + |
| 212 | + else |
| 213 | + bubbleDown leq rightIndex (heap |> Array.set index ( rightA, rightP ) |> Array.set rightIndex ( a, p )) |
| 214 | + |
| 215 | + _ -> |
| 216 | + heap |
0 commit comments