Translated some ideas from 6sigma.us to Haskell

six_sigma_demo_notes.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}

import Control.Comonad
import Data.Functor.Classes
import Data.List


-- [Six Sigma](6sigma.us) Demo Notes

-- # Rolled Throughput Yield
--
-- RTY := product percent_throughput_yields
--
-- The probability that the process will produce zero defects.


-- | Left unimplemented
data Percent

-- | Example newtype
newtype PercentYield = PercentYield { getPercentYield :: Percent }


-- | `Yield` with percentage (`Num`) and value as a GADT
data Yield p a where
  Yield :: Num p => p -> a -> Yield p a


instance Eq2 Yield where
  liftEq2 eqp eq (Yield p x) (Yield q y) = eqp p q && eq x y

instance (Eq p, Eq a) => Eq (Yield p a) where
  (==) = eq2


instance Ord2 Yield where
  liftCompare2 comparep comparex (Yield p x) (Yield q y) = comparep p q `mappend` comparex x y

instance (Ord p, Ord a) => Ord (Yield p a) where
  compare = compare2


instance Show2 Yield where
  liftShowsPrec2 sp1 _ sp2 _ d (Yield p x) = showsBinaryWith sp1 sp2 "Yield" d p x

instance (Show p, Show a) => Show (Yield p a) where
  showsPrec = showsPrec2


instance Num p => Functor (Yield p) where
  fmap :: (a -> b) -> Yield p a -> Yield p b
  fmap f (Yield p x) = Yield p (f x)

-- | Simple `Applicative` instance with multiplicative identity for `pure`
--   and multiplication of percent yields for sequencing.
instance Num p => Applicative (Yield p) where
  pure :: a -> Yield p a
  pure = Yield 1

  (<*>) :: Yield p (a -> b) -> Yield p a -> Yield p b
  Yield pf f <*> Yield px x = Yield (pf * px) (f x)

-- | `Yield` is (almost) trivially a `Comonad`.
--    We use the multiplicative identity for duplication.
instance Num p => Comonad (Yield p) where
  extract :: Yield p a -> a
  extract (Yield _ x) = x

  duplicate :: Yield p a -> Yield p (Yield p a)
  duplicate = Yield 1


-- | Get the percent yield
getYield :: Num p => Yield p a -> p
getYield (Yield p _) = p


main :: IO ()
main = do
  let rtys = [ Yield 0.75 "project 1"
             , Yield (1/2) "project 2"
             , pure "empty project"
             , Yield 0.99 "impressive project"
             ]

  putStrLn "List all individual RTYs for the four projects we specified:"
  mapM print rtys
  putStrLn []

  putStrLn "The RTY for all of the projects:"
  print $ sequenceA rtys
  putStrLn []

  putStrLn "The RTYs of all possible subprojects:"
  mapM_ print . sort . fmap sequenceA . subsequences $ rtys
  putStrLn []


-- > ghci six_sigma_demo_notes.hs
--
-- GHCi, version 8.2.1: http://www.haskell.org/ghc/  :? for help
-- [1 of 1] Compiling Main ( six_sigma_demo_notes.hs, interpreted )
-- Ok, 1 module loaded.
-- *Main
--
-- λ> main
-- List all individual RTYs for the four projects we specified:
-- Yield 0.75 "project 1"
-- Yield 0.5 "project 2"
-- Yield 1.0 "empty project"
-- Yield 0.99 "impressive project"
--
-- The RTY for all of the projects:
-- Yield 0.37124999999999997 ["project 1","project 2","empty project","impressive project"]
--
-- The RTYs of all possible subprojects:
-- Yield 0.37124999999999997 ["project 1","project 2","empty project","impressive project"]
-- Yield 0.37124999999999997 ["project 1","project 2","impressive project"]
-- Yield 0.375 ["project 1","project 2"]
-- Yield 0.375 ["project 1","project 2","empty project"]
-- Yield 0.495 ["project 2","empty project","impressive project"]
-- Yield 0.495 ["project 2","impressive project"]
-- Yield 0.5 ["project 2"]
-- Yield 0.5 ["project 2","empty project"]
-- Yield 0.7424999999999999 ["project 1","empty project","impressive project"]
-- Yield 0.7424999999999999 ["project 1","impressive project"]
-- Yield 0.75 ["project 1"]
-- Yield 0.75 ["project 1","empty project"]
-- Yield 0.99 ["empty project","impressive project"]
-- Yield 0.99 ["impressive project"]
-- Yield 1.0 []
-- Yield 1.0 ["empty project"]