**Paste:**#109473**Authors:**geophf and 1HaskellADay**Language:**Haskell**Channel:**-**Created:**2014-08-16 07:41:39 UTC**Revisions:**- 2014-08-17 15:16:13 UTC #109529 (diff): No title (1HaskellADay)
- 2014-08-16 12:58:59 UTC #109478 (diff): No title (1HaskellADay)
- 2014-08-16 12:58:34 UTC #109477 (diff): No title (1HaskellADay)
- 2014-08-16 07:41:39 UTC #109473: RippleDownRuleto Ergo Sum (geophf)

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | module Control.Logic.Rule.RippleDown where import Control.Arrow import Control.Monad import Control.Monad.Writer import Analytics.Theory.Number -- http://lpaste.net/107480 -- A solution to the problem posted at http://lpaste.net/109350 -- Here we add a new rule when we can't find a soluntion in the ruleset. type Name = String data Pred a = P { name :: Name, is :: (a -> Bool) } instance Show (Pred a) where show (P name _) = "Pred " ++ name data Rule a = Top (Rule a) | R (Pred a) (Rule a) (Rule a) | Terminal instance Show (Rule a) where show (Top _) = "⟙" show (R p _ _) = "Rule " ++ name p show Terminal = "⟘" children :: Rule a -> [Rule a] children (Top r) = [r] children (R p l r) = [l, r] children Terminal = [] -- a rule is either proves the value or ripples down to a (child) rule that -- does ... or not. Then you need to add a rule for that case. data RDR a = RippleDownRuleSet (Rule a) instance Show a => Show (RDR a) where show (RippleDownRuleSet rule) = "RDR " ++ showRule rule showRule :: Rule a -> String showRule rule = show rule ++ showChildren (children rule) showChildren :: [Rule a] -> String showChildren [] = "" showChildren (h:t) = " { " ++ showRule h ++ " " ++ concatMap showRule t ++ " } " -- our path through the RDR accumulates the proofs (those rules that fired) -- and has the most recent rule that fired (even if 'most recent' is ⟙) data Way a = Tau { prev :: Rule a, reasons :: [Rule a] } -- The τ that can be told is not the eternal τ. ... Geddit? fnord :: a -> RDR a -> Writer [Rule a] (Maybe (Rule a)) -- so Writer == Way fnord fivish (RippleDownRuleSet rules) = flow fivish rules flow :: a -> Rule a -> Writer [Rule a] (Maybe (Rule a)) flow x top@(Top rule) = tell [top] >> flow x rule >>= accum top True flow x rule@(R p t f) = let fired = is p x in when fired (tell [rule]) >> flow x (if fired then t else f) >>= accum rule fired flow x Terminal = return Nothing -- and we're done! fire :: MonadPlus m => Bool -> (a -> m a) fire True = return fire False = const mzero accum :: (Monad n, MonadPlus m) => Rule a -> Bool -> (m (Rule a) -> n (m (Rule a))) accum rule fired = return . (flip mplus (fire fired rule)) oneRule :: (Integral a, Num a, Eq a) => RDR a oneRule = RippleDownRuleSet (Top divisible) divisible :: (Eq a, Num a, Integral a) => Rule a divisible = R (P "divisible by 5" ((== 0) . (flip mod 5))) fiver Terminal fiver :: (Num a, Eq a) => Rule a fiver = R (P "it's 5" (== 5)) Terminal Terminal insertRule :: Pred a -> Writer [Rule a] (RDR a) -> Writer [Rule a] (RDR a) insertRule fromPred = censor (modifyRuleset fromPred) addRule :: a -> Pred a -> RDR a -> RDR a addRule num p ruleset = let (_, answerSet) = runWriter (insertRule p (fnord num ruleset >> return ruleset)) in RippleDownRuleSet $ head answerSet modifyRuleset :: Pred a -> [Rule a] -> [Rule a] modifyRuleset p rules = reverse $ m' (reverse rules) where m' [Top rule] = [Top (mkRule p rule rule)] -- go either way from Top m' (R q s f:rest) = (R q s (mkRule p s f):rest) mkRule p r1 r2 = R p r1 r2 {-- ... and our adder run: *Control.Logic.Rule.RippleDown> oneRule RDR ⟙ { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } *Control.Logic.Rule.RippleDown> runWriter (fnord 23 oneRule ) (Just ⟙,[⟙]) -- no answer for 23, and that's just wrong! *Control.Logic.Rule.RippleDown> addRule 23 (P "digits sum to 5" ((== 5) . blackAdder)) oneRule RDR ⟙ { Rule digits sum to 5 { ⟘ Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } } -- so we now have a ruleset where the digits sum to 5. Let's try it out! *Control.Logic.Rule.RippleDown> let sumRule = it *Control.Logic.Rule.RippleDown> runWriter (fnord 23 sumRule ) (Just Rule digits sum to 5,[⟙,Rule digits sum to 5]) -- yup that worked for 23 ... do 10 and 5 still work? *Control.Logic.Rule.RippleDown> runWriter (fnord 10 sumRule ) (Just Rule divisible by 5,[⟙,Rule divisible by 5]) -- 10 works ... *Control.Logic.Rule.RippleDown> runWriter (fnord 5 sumRule ) (Just Rule digits sum to 5,[⟙,Rule digits sum to 5]) -- but 5 didn't :( ... the issue here is how I add in the rule, if I add it to ⟙ and then append the whole ruleset to the else-branch, then if the digits sum to 5, the other rules don't get tried. But then, if I append the whole ruleset to the then-branch, then they don't get executed if the digits don't sum to five (such as 10). So then we run into the whole big problem of ripple down rules where child branches of similar classes mirror each other in some regards. RDR is an interesting concept, and have been used to some effect. An airline uses it to distribute parts: millions of parts, thousands of kinds their RDR system has 2.5 MILLION rules in their set. WOWsers! They've come across this problem and have solved it or inbred it. Okay. RDR. That was fun! --} {-- Epilogue: So you see the NOW working code above. Whereas before, when I inserted a new rule into the ruleset, I terminated it at that rule with the continuation branch to either the left (the then-branch) OR to the right (the else-branch). NOW what I do is to loop in both branches so that the newly interposed rule flows down to the left and to the right and we continue testing on it, depending on how its (last successfully-fired) parent behaved. Simple, simple fix that gets us the desired results: *Control.Logic.Rule.RippleDown> oneRule RDR ⟙ { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } *Control.Logic.Rule.RippleDown> runWriter (fnord 23 oneRule ) (Just ⟙,[⟙]) *Control.Logic.Rule.RippleDown> addRule 23 (P "digits sum to 5" ((== 5) . blackAdder )) oneRule RDR ⟙ { Rule digits sum to 5 { -- newly inserted rule Rule divisible by 5 { -- now branches to the left Rule it's 5 { ⟘ ⟘ } ⟘ } Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } } -- AND to the right! YAY! *Control.Logic.Rule.RippleDown> let sumRule = it *Control.Logic.Rule.RippleDown> runWriter (fnord 23 sumRule) (Just Rule digits sum to 5,[⟙,Rule digits sum to 5]) *Control.Logic.Rule.RippleDown> runWriter (fnord 10 sumRule) (Just Rule divisible by 5,[⟙,Rule divisible by 5]) *Control.Logic.Rule.RippleDown> runWriter (fnord 5 sumRule) (Just Rule it's 5,[⟙,Rule digits sum to 5,Rule divisible by 5,Rule it's 5]) -- the 5-rule now works as desired. YAY! --} -- so let's add that to the rule set, and two other rules 'discovered' -- by my daughters, Isabel and Elena Marie. sumRule :: Integral a => RDR a sumRule = addRule 23 addidible oneRule -- here's our 'digits add up to 5' predicate: addidible :: (Eq a, Num a, Integral a) => Pred a addidible = P "digits sum to 5" ((== 5) . blackAdder) blackAdder :: (Eq n, Num n, Integral n) => n -> n blackAdder 0 = 0 blackAdder n = let (a, b) = n `divMod` 10 in b + blackAdder a -- Now let's add Isabel's and Elena Marie's rules: --------------------- -- Here's Isabel's rule: 27, or, as Elena Marie explained: there are 2 -- '5's (5 x 5), and you add 2 to that, or (2, 2) or exponent == remainder isIsabel :: (Eq a, Num a, Integral a) => Pred a isIsabel = P "There's x 5's as a multiple with remainder x" ((\(a, b) -> a == b) . twentySeven) twentySeven :: (Eq a, Num a, Integral a) => a -> (a, a) twentySeven x = let (a, b) = x `divMod` 5 in if a >= 5 && b /= 0 then (\(p, q) -> (1 + p, b + q)) (twentySeven a) else (a, b) -- there's an arrow for the above application above, I'm sure ... :/ -- so, 6, 27, 128, 629, ... all work with rule 27 -- runWriter (fnord 27 sumRule) ~> (Just ⟙,[⟙]) bunsoh :: Integral a => RDR a bunsoh = addRule 27 isIsabel sumRule -- runWriter (fnord 27 bunsoh) ~> -- (Just Rule There's x 5's as a multiple with remainder x, ...) -- Now, Elena Marie's rule (after I got her to stop naming out multiples of -- 5's as she rolled her eyes, being the sophisticated teen that she is) isElena :: (Eq a, Num a, Integral a) => Pred a isElena = P "The number is coprime to 5" (isLeft . coprime 5) isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False -- pretty clever. "2, Papa!" she exclaimed finally. "Why?" I demanded. -- "Because they both are divisible by 1 at most." -- My daughter just 'discovered' coprimality. *Proud* -- Okay, let's add this new rule -- runWriter (fnord 2 bunsoh) ~> (Just ⟙,[⟙]) até :: Integral a => RDR a até = addRule 2 isElena summer -- runWriter (fnord 2 até) ~> (Just Rule The number is coprime to 5, ...) -- and it, of course, works with any coprime number of 5: -- runWriter (fnord 622 até) ~> (Just Rule The number is coprime to 5,[⟙, ...]) {-- até ~> RDR ⟙ { Rule The number is coprime to 5 { Rule There's x 5's as a multiple with remainder x { Rule digits sum to 5 { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } Rule digits sum to 5 { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } } Rule There's x 5's as a multiple with remainder x { Rule digits sum to 5 { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } Rule digits sum to 5 { Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } Rule divisible by 5 { Rule it's 5 { ⟘ ⟘ } ⟘ } } } } } And just one more. How come 622 didn't fire the summer rule? Because the summer rule applies only when the sum IS 5, not when it's a multiple of 5. So, two ways to change this. We change the predicate so that it checks for multiples, or we add a rule. --} summer :: Integral a => RDR a summer = addRule 622 (P "digits sum to a multiple of 5" ((== 0) . (flip mod 5) . blackAdder)) bunsoh |

13:33: Warning: Redundant bracket

Found:

is :: (a -> Bool)

Why not:

is :: a -> Bool

64:24: Warning: Redundant bracket

Found:

Bool -> (a -> m a)

Why not:

Bool -> a -> m a

68:46: Warning: Redundant bracket

Found:

Bool -> (m (Rule a) -> n (m (Rule a)))

Why not:

Bool -> m (Rule a) -> n (m (Rule a))

70:20: Warning: Redundant bracket

Found:

return . (flip mplus (fire fired rule))

Why not:

return . flip mplus (fire fired rule)

70:29: Warning: Use section

Found:

(flip mplus (fire fired rule))

Why not:

(`mplus` (fire fired rule))

76:36: Warning: Redundant bracket

Found:

(== 0) . (flip mod 5)

Why not:

(== 0) . flip mod 5

76:45: Warning: Use section

Found:

(flip mod 5)

Why not:

(`mod` 5)

93:30: Warning: Redundant bracket

Found:

(R q s (mkRule p s f) : rest)

Why not:

R q s (mkRule p s f) : rest

94:10: Error: Eta reduce

Found:

mkRule p r1 r2 = R p r1 r2

Why not:

mkRule = R

196:16: Warning: Use uncurry

Found:

\ (a, b) -> a == b

Why not:

uncurry (==)

Note: increases laziness

201:27: Warning: Use ***

Found:

\ (p, q) -> (1 + p, b + q)

Why not:

(+) 1 *** (+) b

273:35: Warning: Use section

Found:

(flip mod 5)

Why not:

(`mod` 5)

273:35: Warning: Redundant bracket

Found:

(flip mod 5) . blackAdder

Why not:

flip mod 5 . blackAdder