├── .gitignore ├── Norm.hs ├── ProbDist.hs ├── Morality.hs ├── Preorder.hs ├── README.md └── Example.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.swp 4 | *.swo 5 | Example 6 | -------------------------------------------------------------------------------- /Norm.hs: -------------------------------------------------------------------------------- 1 | -- defines the Norm class and implements related functions 2 | module Norm where 3 | 4 | import Data.List 5 | import Data.Function 6 | import Control.Applicative 7 | 8 | class Norm a where 9 | scale :: Double -> a -> a 10 | add :: a -> a -> a 11 | norm :: a -> Double 12 | 13 | instance Norm Double where 14 | scale = (*) 15 | add = (+) 16 | norm = abs 17 | 18 | instance (Norm a) => Norm [a] where 19 | scale = map . scale 20 | add x = map (uncurry add) . zip x 21 | norm = sum . map ((** 2) . norm) 22 | 23 | sub :: (Norm a) => a -> a -> a 24 | sub x = add x . scale (-1) 25 | 26 | dist :: (Norm a) => a -> a -> Double 27 | dist x = norm . sub x 28 | 29 | nearest :: (Norm a) => [a] -> a -> a 30 | nearest xs x = minimumBy (compare `on` (dist x)) xs 31 | -------------------------------------------------------------------------------- /ProbDist.hs: -------------------------------------------------------------------------------- 1 | -- Defines the ProbDist monad and implements associated functions 2 | module ProbDist where 3 | 4 | import Data.Tuple 5 | import Data.List 6 | import Data.Function 7 | import Control.Monad 8 | import Control.Applicative 9 | import Norm 10 | 11 | data ProbDist a = ProbDist [(a, Double)] 12 | deriving (Eq, Show) 13 | 14 | instance (Ord a) => Ord (ProbDist a) where 15 | compare (ProbDist xs) (ProbDist ys) = compare (sortBy (compare `on` fst) xs) (sortBy (compare `on` snd) ys) 16 | 17 | instance Functor ProbDist where 18 | fmap f = ProbDist . map (\(x, y) -> (f x, y)) . getPairs 19 | 20 | instance Monad ProbDist where 21 | x >>= f = flatten $ ProbDist $ zip (map f $ getEvents x) $ getProbs x 22 | return x = ProbDist [(x, 1.0)] 23 | 24 | instance Applicative ProbDist where 25 | pure = return 26 | (<*>) = ap 27 | 28 | instance (Ord a) => Norm (ProbDist a) where 29 | add x y = ProbDist $ zip (getEvents $ canonicalOrder x) $ map (uncurry (+)) $ zip (getProbs $ canonicalOrder x) (getProbs $ canonicalOrder y) 30 | scale d = ProbDist . map (\(y, z) -> (y, d * z)) . getPairs 31 | norm = norm . getProbs 32 | 33 | getPairs :: ProbDist a -> [(a, Double)] 34 | getPairs (ProbDist x) = x 35 | 36 | getEvents :: ProbDist a -> [a] 37 | getEvents (ProbDist x) = map fst x 38 | 39 | getProbs :: ProbDist a -> [Double] 40 | getProbs (ProbDist x) = map snd x 41 | 42 | canonicalOrder :: (Ord a) => ProbDist a -> ProbDist a 43 | canonicalOrder (ProbDist xs) = ProbDist (sortBy (compare `on` fst) xs) 44 | 45 | -- this is just the monadic join 46 | flatten :: ProbDist (ProbDist a) -> ProbDist a 47 | flatten p = ProbDist $ concat $ map (\(x, y) -> zip (getEvents x) $ map (y *) $ getProbs x) $ getPairs p 48 | 49 | -- combine equal events 50 | reduce :: (Eq a) => ProbDist a -> ProbDist a 51 | reduce dist = ProbDist $ map (\x -> (fst $ head x, sum $ map snd x)) $ groupBy ((==) `on` fst) $ getPairs dist 52 | -------------------------------------------------------------------------------- /Morality.hs: -------------------------------------------------------------------------------- 1 | module Morality where 2 | 3 | import Data.Maybe 4 | import Data.List 5 | import Control.Applicative 6 | import Preorder 7 | import ProbDist 8 | import Norm 9 | 10 | type WorldState = String 11 | 12 | type PossibleState = ProbDist WorldState 13 | 14 | type MoralTheory = PreorderFamily PossibleState 15 | 16 | invert :: (Eq a) => (a -> a) -> [a] -> a -> a 17 | invert f domain x = fromJust $ find ((== x) . f) domain 18 | 19 | -- infer a moral theory from adjacency lists approximating each preorder 20 | -- and functions from your own states to those of others 21 | inferMoralTheory :: [AdjacencyList PossibleState] -> [WorldState -> WorldState] -> MoralTheory 22 | inferMoralTheory adjLists fs = isoSubFamily $ map (\n -> (fromAdjListNormed $ adjLists !! n, map (\m -> fmap $ (fs !! m) . invert (fs !! n) domain) [0..maxind])) [0..maxind] where 23 | maxind = length adjLists - 1 24 | domain = concat $ map getEvents $ map fst $ head adjLists 25 | 26 | -- randomize a list of possible states across the moral community 27 | veil :: MoralTheory -> PossibleState -> PossibleState 28 | veil theory state = scale (1.0 / fromIntegral (length theory)) $ foldr1 add $ (snd $ head theory) <*> return state 29 | 30 | -- same as above, but ignore self (assumes self's preferences have index 0) 31 | veilMinusSelf :: MoralTheory -> PossibleState -> PossibleState 32 | veilMinusSelf theory state = scale (1.0 / fromIntegral (length theory - 1)) $ foldr1 add $ (tail $ snd $ head theory) <*> return state 33 | 34 | -- judges which state is Just (punnyness >9000), or Nothing 35 | judge :: MoralTheory -> PossibleState -> PossibleState -> Maybe PossibleState 36 | judge theory state1 state2 = case (comp (veil theory state1) (veil theory state2), comp (veilMinusSelf theory state1) (veilMinusSelf theory state2)) of 37 | (PGT, PGT) -> Just state1 38 | (PLT, PLT) -> Just state2 39 | _ -> Nothing 40 | where 41 | comp = pCompare $ fst $ head theory 42 | -------------------------------------------------------------------------------- /Preorder.hs: -------------------------------------------------------------------------------- 1 | -- Defines the Preorder type and implements associated functions 2 | module Preorder where 3 | 4 | import Data.List 5 | import Data.Tuple 6 | import Data.Maybe 7 | import Data.Function 8 | import Norm 9 | 10 | data Preordering = PLT -- less than 11 | | PGT -- greater than 12 | | EQV -- equivalent 13 | | INC -- incomparable 14 | deriving (Eq) 15 | 16 | instance Show Preordering where 17 | show PLT = "<=" 18 | show PGT = ">=" 19 | show EQV = "~=" 20 | show INC = "!!" 21 | 22 | instance Read Preordering where 23 | readsPrec _ s = case s of 24 | "<=" -> [(PLT, "")] 25 | ">=" -> [(PGT, "")] 26 | "~=" -> [(EQV, "")] 27 | "!!" -> [(INC, "")] 28 | _ -> [] 29 | 30 | data Preorder a = Preorder (a -> a -> Preordering) 31 | 32 | -- (a,bs) is such that b in bs if a >= b 33 | type AdjacencyList a = [(a,[a])] 34 | 35 | -- a set of partial orders with a complete set of functions between them 36 | -- [(domain, function : domain -> range)] 37 | -- domains and ranges must be in the same order 38 | type PreorderFamily a = [(Preorder a, [a -> a])] 39 | 40 | ---- Preorder functions ---- 41 | 42 | pCompare :: Preorder a -> a -> a -> Preordering 43 | pCompare (Preorder f) = f 44 | 45 | fromTotalOrder :: (Ord a) => Preorder a 46 | fromTotalOrder = Preorder (\x -> (\y -> 47 | case compare x y of 48 | LT -> PLT 49 | GT -> PGT 50 | EQ -> EQV 51 | )) 52 | 53 | inAdjList :: (Eq a) => AdjacencyList a -> a -> Bool 54 | inAdjList adjList = flip elem $ map fst adjList 55 | 56 | getAdj :: (Eq a) => AdjacencyList a -> a -> [a] 57 | getAdj adjList a = snd $ fromJust $ find ((== a) . fst) adjList 58 | 59 | fromAdjList :: (Eq a) => AdjacencyList a -> Preorder a 60 | fromAdjList adjList = Preorder (\x -> (\y -> 61 | if inAdjList adjList x && inAdjList adjList y 62 | then if elem y (getAdj adjList x) 63 | then if elem x (getAdj adjList y) 64 | then EQV 65 | else PGT 66 | else if elem x (getAdj adjList y) 67 | then PLT 68 | else INC 69 | else INC 70 | )) 71 | 72 | toAdjList :: (Enum a) => Preorder a -> a -> AdjacencyList a 73 | toAdjList (Preorder f) minElem = map (\x -> (x, filter (\y -> f x y == PGT || f x y == EQV) all)) all where 74 | all = enumFrom minElem 75 | 76 | -- allows a preorder of infinitely many normed items to be defined using only finitely many entries 77 | -- comparison uses the closest points defined 78 | fromAdjListNormed :: (Norm a, Eq a) => AdjacencyList a -> Preorder a 79 | fromAdjListNormed adjList = Preorder (pCompare p `on` nearest (map fst adjList)) where 80 | p = fromAdjList adjList 81 | 82 | ---- PreorderFamily functions ---- 83 | 84 | -- makes a minimal set of elements in each ordering incomparable 85 | -- such that each map is an isomorphism on the set of elements comparable to at least one other 86 | -- family must be finite 87 | isoSubFamily :: PreorderFamily a -> PreorderFamily a 88 | isoSubFamily family = foldr (.) id (map isoSubFamilyHelper [0 .. length family - 1]) family 89 | 90 | -- makes incomparable any elements of the poset at index which disagree under one or more functions 91 | isoSubFamilyHelper :: Int -> PreorderFamily a -> PreorderFamily a 92 | isoSubFamilyHelper index family = map (\m -> (Preorder $ newPO m, snd $ family !! m)) [0 .. length family - 1] where 93 | newPO m x y = if all (== pCompare po x y) (map (\n -> pCompare (fpo n) (f n x) (f n y)) [0 .. length family - 1]) 94 | then pCompare po x y 95 | else INC 96 | where 97 | po = fst $ family !! m 98 | fpo n = fst $ family !! n 99 | f n = (snd $ family !! m) !! n 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Formal-Morality 2 | --------------- 3 | 4 | A heavily mathematical Pseudo-Rawlsian moral framework. For an example, compile Example.hs using GHC. 5 | 6 | ## Philosophical Background 7 | 8 | The full philosophical arguments are beyond the scope of this repo, but a brief summary is necessary. 9 | John Rawls's *A Theory of Justice*, perhaps the most influential piece of modern philosophy, 10 | defines both a framework for creating moral theories and 11 | a moral theory to which he argues the framework gives rise. 12 | This framework revolves around the central principle of the *Veil of Ignorance*, essentially asking 13 | how a moral theory would be devised by individuals who had no knowledge of their station in life. 14 | 15 | I find this notion very attractive, but it has two key difficulties: 16 | 17 | 1. People value different things differently, so some sort of correspondence is required. 18 | 19 | 2. People have different risk adversities. 20 | 21 | I attempt to formalize a method for overcoming these obstacles. 22 | Other such formalisms exist, most notably Utilitarianism. However, the assumptions of Utilitarianism 23 | seem too strong to me. My formalism resembles Utilitarianism in some ways, but with the utility 24 | function replaced by the much weaker notion of a preorder. 25 | As a consequence, theories it creates generally impose relatively few duties. 26 | 27 | ## Moral Theory 28 | 29 | The theory requires that a each member of a community have: 30 | 31 | 1. A preorder of values for probability distributions of states of the world. 32 | Simplified, that means that given the two statements of the form 33 | "The world will look like P with probability X, and like Q with probability Y", 34 | you may be able to say that one is better than the other, or that they are equal good. 35 | However, it is also possible that they are incomparable. 36 | For example, I might love my children and love my spouse, but could not choose which I valued more not 37 | because I love them equally but because I love them differently. 38 | This model fits with the observation that when asked to produce a utility function, 39 | people are highly inconsistent--not because their utility changes rapidly, but because their utility 40 | function is ill-defined. 41 | 42 | 2. The ability to recognize a state of the world from their own perspective as essentially 43 | equivalent to another state of the world from another's perspective. For example, I might recognize that 44 | your being in love from your perspective is qualitatively the same as my being in love from mine, 45 | but perhaps your experience of writing Haskell is not the same as mine. 46 | 47 | A moral theory is constructed by linking together the states of the world from each person's perspective, 48 | using their recognition of other's perspectives, forming the *Consensus Family*. 49 | If everyone values their equivalent for A over their 50 | equivalent for B, I believe that this automatically imposes a moral weight of A over B on 51 | every member of the community. This seems natural because it obeys the values and mutual recognition 52 | of every member. 53 | 54 | Given a choice between probability distributions A and B, choosing A is a moral duty for a person 55 | if the following conditions hold: 56 | 57 | 1. (Consensus Behind the Veil) When randomized uniformly across the equivalent states for all members 58 | of the community, the randomized version of A is ≥ the randomized version of B in the subset 59 | of that person's preorder contained in the Consensus Family, and the reverse (with B and A switched) is not true. 60 | 61 | 2. (No Duty to Self) The same holds when the person choosing is omitted. 62 | 63 | 3. (Self-Preservation) The choice of A over B does not pose a significant risk of compromising the person's 64 | membership in the moral community, e.g. by killing them or by so emotionally damaging them that they 65 | are no longer able to recognize the same values. 66 | 67 | ## Formal Mathematics 68 | 69 | Requirement 1 is a preorder of probability distributions, and the second requirement lifts 70 | naturally to isomorphisms between them. 71 | The process of "connecting" the preorders is just taking the unique maximal groupoid of preorders 72 | constructed from sub-preorders of those given. 73 | -------------------------------------------------------------------------------- /Example.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Tuple 4 | import Morality 5 | import Preorder 6 | import ProbDist 7 | 8 | worldStates :: [WorldState] 9 | worldStates = ["Alice falling in love", "Bob falling in love", "Both getting $10,000"] 10 | 11 | -- convenient way to write probability distributions 12 | unpack :: [Double] -> PossibleState 13 | unpack = ProbDist . zip worldStates 14 | 15 | -- alice strictly prefers at any probability herself falling in love to bob falling in love, 16 | -- and bob falling in love to both getting $10,000 17 | -- conveniently this lines up with the derived total order on the ProbDists 18 | alicePref :: Preorder PossibleState 19 | alicePref = fromTotalOrder 20 | 21 | -- bob values his own love at probability x as much as money at probability 3x, but prefers both strictly to alice's love 22 | bobPref :: Preorder PossibleState 23 | bobPref = Preorder (\x -> (\y -> case compare (3.0 * probN x 1 + probN x 2) (3.0 * probN y 1 + probN y 2) of 24 | LT -> PLT 25 | GT -> PGT 26 | EQ -> case compare (probN x 0) (probN x 1) of 27 | LT -> PLT 28 | GT -> PGT 29 | EQ -> EQV 30 | )) 31 | where 32 | probN x n = getProbs x !! n 33 | 34 | -- Alice recognizes' Bob's value of his own love to be substantially similar to her own, 35 | -- and simililarly his appreciation of his friend's love and of his and his friend's money 36 | aliceBobCorrespondence :: WorldState -> WorldState 37 | aliceBobCorrespondence "Alice falling in love" = "Bob falling in love" 38 | aliceBobCorrespondence "Bob falling in love" = "Alice falling in love" 39 | aliceBobCorrespondence "Both getting $10,000" = "Both getting $10,000" 40 | 41 | -- same correspondence, lifted to PossibleStates 42 | abcLifted :: PossibleState -> PossibleState 43 | abcLifted = canonicalOrder . fmap aliceBobCorrespondence 44 | 45 | -- inverse of above 46 | bacLifted :: PossibleState -> PossibleState 47 | bacLifted = canonicalOrder . fmap (invert aliceBobCorrespondence worldStates) 48 | 49 | aliceTestTheory :: MoralTheory 50 | aliceTestTheory = isoSubFamily [(alicePref, [id, abcLifted]), (bobPref, [bacLifted, id])] 51 | 52 | bobTestTheory :: MoralTheory 53 | bobTestTheory = isoSubFamily [(bobPref, [id, bacLifted]), (alicePref, [abcLifted, id])] 54 | 55 | exampleAlicePairs :: [(String, PossibleState, PossibleState)] 56 | exampleAlicePairs = [("Alice must choose Bob falling in love over the money, because both agree that the veiled situation of falling in love half the time is more valuable than 100% chance of getting the money. The unveiled situation happens to agree with Alice's personal values as well.", 57 | unpack [0.0, 1.0, 0.0], unpack [0.0, 0.0, 1.0]), 58 | ("Alice values falling in love over getting the money, and Bob is indifferent for his equivalent situation. This would result in a duty to Alice, except it would be a duty to herself, which is impossible.", 59 | unpack [1.0, 0.0, 0.0], unpack [0.0, 0.0, 1.0]), 60 | ("Alice, were she in Bob's shoes, would value Bob falling in love over the money at any probability, but when her values are not imposed on Bob he does not value the options this way. Thus no duty is created.", 61 | unpack [0.75, 0.25, 0.0], unpack [0.0, 0.0, 1.0])] 62 | 63 | exampleBobPairs :: [(String, PossibleState, PossibleState)] 64 | exampleBobPairs = [("The second case above, from Bob's perspective. While Alice cannot have a duty to herself, Bob can have a duty to her. Note that the unveiled situation disagrees with Bob's own values, so in this case the moral theory has nontrivial implications.", 65 | unpack [1.0, 0.0, 0.0], unpack [0.0, 0.0, 1.0])] 66 | 67 | main :: IO () 68 | main = do 69 | putStrLn $ "Worldstates: " ++ show worldStates 70 | putStrLn "Alice's values: Lexicographical (Alice in love, Bob in love, money)" 71 | putStrLn "Bob's values: Bob in love with probability x is valued the same as money with probability 3x, Alice in love is valued least." 72 | putStrLn "Alice -> Bob Correspondence: " 73 | sequence_ $ map (\ws -> putStrLn $ '\t' : ws ++ " -> " ++ aliceBobCorrespondence ws) worldStates 74 | putStrLn "\nAlice's duties: " 75 | sequence_ $ map (\(d, a, b) -> putStrLn ('\t' : show (a, b)) >> putStrLn ("\tJudgement: " ++ show (judge aliceTestTheory a b)) >> putStrLn ('\t' : d ++ "\n")) exampleAlicePairs 76 | putStrLn "\nBob's duties: " 77 | sequence_ $ map (\(d, a, b) -> putStrLn ('\t' : show (a, b)) >> putStrLn ("\tJudgement: " ++ show (judge bobTestTheory a b)) >> putStrLn ('\t' : d ++ "\n")) exampleBobPairs 78 | --------------------------------------------------------------------------------