Last active
December 30, 2017 22:40
-
-
Save giuliohome/bf55e4d281bcb6f42fee7b416f55ae45 to your computer and use it in GitHub Desktop.
discussed https://twitter.com/giuliohome_2017/status/947196667635396615 from https://bartoszmilewski.com/2017/12/29/stalking-a-hylomorphism-in-the-wild/
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
-- Is there a trick to getting this done easier? | |
-- yep, look at TryAgainFromScratch.hs | |
module Bridge where | |
import Data.List | |
import Data.Ord | |
import qualified Data.Map as Map | |
import Data.Maybe | |
main :: IO () | |
main = do | |
--input <- readFile "Data.txt" | |
let input = unlines test | |
let pool = fmap toPiece (lines input) | |
let best = bestChain pool | |
print $ score $ head best | |
print "---" | |
print $ best | |
print "---" | |
let poolScored = fmap toScoredPiece (lines input) | |
print $ hylo chainScoredAlg coalgScored (0, presortScored poolScored) | |
type Piece = (Int, Int) | |
type ScoredPiece = ((Int, Int), Score) | |
data Score = Assign Int | |
deriving Show | |
type Chain = [Piece] | |
type ScoredChain = ([Piece], Score) | |
getScore :: ScoredChain -> Int | |
getScore (gchain, Assign gscore) = gscore | |
type Pool = Map.Map Int [Int] | |
type ScoredPool = Map.Map Int ([Int],Score) | |
addPiece :: Piece -> Pool -> Pool | |
addPiece (m, n) = if m /= n | |
then add m n . add n m | |
else add m n | |
where | |
add m n pool = | |
case Map.lookup m pool of | |
Nothing -> Map.insert m [n] pool | |
Just lst -> Map.insert m (n : lst) pool | |
addScoredPiece :: ScoredPiece -> ScoredPool -> ScoredPool | |
addScoredPiece ((m, n),score) = if m /= n | |
then add ((m, n),score) . add ((n, m),score) | |
else add ((m, n),score) | |
where | |
add ((m, n), Assign score) pool = | |
case Map.lookup m pool of | |
Nothing -> Map.insert m ([n], Assign score) pool | |
Just (lst, Assign lstscore) -> | |
Map.insert m ((n : lst), Assign $ score + lstscore) pool | |
removePiece :: Piece -> Pool -> Pool | |
removePiece (m, n) = if m /= n | |
then rem m n . rem n m | |
else rem m n | |
where | |
rem :: Int -> Int -> Pool -> Pool | |
rem m n pool = | |
case fromJust $ Map.lookup m pool of | |
[] -> Map.delete m pool | |
lst -> Map.insert m (delete n lst) pool | |
removeScoredPiece :: Piece -> ScoredPool -> ScoredPool | |
removeScoredPiece (m, n) = if m /= n | |
then rem m n . rem n m | |
else rem m n | |
where | |
rem :: Int -> Int -> ScoredPool -> ScoredPool | |
rem m n pool = | |
case fromJust $ Map.lookup m pool of | |
([],_) -> Map.delete m pool | |
(lst, Assign lstscore) -> Map.insert m ((delete n lst), Assign(lstscore-n-m)) pool | |
presort :: [Piece] -> Pool | |
presort = foldr addPiece Map.empty | |
presortScored :: [ScoredPiece] -> ScoredPool | |
presortScored = foldr addScoredPiece Map.empty | |
-- Tree of chains | |
-- Each node contains a port | |
-- and a list of smaller chains | |
-- Top node will contain port 0 | |
-- data Node b a = Node { me :: a, kids :: [Node a b] } deriving Show | |
-- data NodeR a b = Rev (Node b a) deriving Show | |
data Rose = NodeR Int [Rose] | |
deriving Show | |
data ScoredRose = NodeSR (Int,Score) [Rose] | |
deriving Show | |
-- Represent the tree as a fixed point of a functor | |
data TreeF a = NodeF Int [a] | |
deriving Functor | |
-- data ScoredTreeF a = NodeSF (Int,Score) [a] | |
-- deriving Functor | |
newtype Fix f = Fix { unFix :: f (Fix f) } | |
type Tree = Fix TreeF | |
type Coalgebra f a = a -> f a | |
-- This coalgebra builds a tree using anamorphism | |
coalg :: Coalgebra TreeF (Int, Pool) | |
coalg (n, pool) = | |
case Map.lookup n pool of | |
Nothing -> NodeF n [] | |
Just ms -> NodeF n [(m, removePiece (m, n) pool) | m <- ms] | |
coalgScored :: Coalgebra TreeF (Int, ScoredPool) | |
coalgScored (n, pool) = | |
case Map.lookup n pool of | |
Nothing -> NodeF n [] | |
Just (ms, Assign scorems) -> NodeF n | |
[ (m, removeScoredPiece (m, n) pool) | m <- ms] | |
ana :: Functor f => Coalgebra f a -> a -> Fix f | |
ana coalg = Fix . fmap (ana coalg) . coalg | |
type Algebra f a = f a -> a | |
-- This algebra is for testing | |
tAlg :: Algebra TreeF Rose | |
tAlg (NodeF n lst) = NodeR n lst | |
-- This algebra turns a tree into a list of chains | |
chainAlg :: Algebra TreeF (Int, [Chain]) | |
chainAlg (NodeF n []) = (n, []) | |
chainAlg (NodeF n lst) = (n, concat [push (n, m) bs | (m, bs) <- lst]) | |
where | |
push :: (Int, Int) -> [Chain] -> [Chain] | |
push (n, m) [] = [[(n, m)]] | |
push (n, m) bs = [(n, m) : br | br <- bs] | |
-- This algebra turns a tree into a list of scored chains | |
extrScore :: [ScoredChain] -> Int | |
extrScore bs = maximum $ fmap getScore bs | |
chainScoredAlg :: Algebra TreeF (Int, [ScoredChain]) | |
chainScoredAlg (NodeF n []) = (n, []) | |
chainScoredAlg (NodeF n lst) = | |
(n, concat [push (n, m) bs | (m, bs) <- lst]) | |
where | |
push :: (Int, Int) -> [ScoredChain] -> [ScoredChain] | |
push (n, m) [] = [ ([(n, m)], Assign (m + n))] | |
push (n, m) bs = | |
([(n, m)], Assign (n + m + (extrScore bs))) : bs | |
cata :: Functor f => Algebra f a -> Fix f -> a | |
cata alg = alg . fmap (cata alg) . unFix | |
hylo :: Functor f => Algebra f a -> Coalgebra f b -> b -> a | |
hylo f g = f . fmap (hylo f g) . g | |
score :: Chain -> Int | |
score = sum . fmap score1 | |
where score1 (m, n) = m + n | |
bestChain :: [Piece] -> [Chain] | |
bestChain pieces = | |
let pool = presort pieces | |
(_, chains) = hylo chainAlg coalg (0, pool) | |
-- in maximumBy (comparing score) chains | |
maxscore = maximum $ fmap score chains | |
in filter (\c -> score c == maxscore) chains | |
toPiece :: String -> Piece | |
toPiece s = let (a, b) = break (== '/') s | |
in (read a, read (tail b)) | |
toScoredPiece :: String -> ScoredPiece | |
toScoredPiece s = let (a, b) = break (== '/') s | |
in ((read a, read (tail b)), Assign (read a + read (tail b))) | |
test = ["0/2", | |
"2/2", | |
"2/3", | |
"3/4", | |
"3/5", | |
"0/1", | |
"10/1", | |
"9/10"] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
module Bridge where | |
import Data.List | |
import Data.Ord | |
import qualified Data.Map as Map | |
import Data.Maybe | |
main :: IO () | |
main = do | |
--input <- readFile "Data.txt" | |
let input = unlines test | |
let pool = fmap toPiece (lines input) | |
let best = bestChain pool | |
print $ score $ head best | |
print "---" | |
print $ best | |
print "---" | |
let (_,chains) = hylo chainAlg coalg (0, presort pool) | |
print $ sortBy (comparing $ negate . fst) $ map (\c -> (score c, c)) chains | |
type Piece = (Int, Int) | |
type Chain = [Piece] | |
type Pool = Map.Map Int [Int] | |
addPiece :: Piece -> Pool -> Pool | |
addPiece (m, n) = if m /= n | |
then add m n . add n m | |
else add m n | |
where | |
add m n pool = | |
case Map.lookup m pool of | |
Nothing -> Map.insert m [n] pool | |
Just lst -> Map.insert m (n : lst) pool | |
removePiece :: Piece -> Pool -> Pool | |
removePiece (m, n) = if m /= n | |
then rem m n . rem n m | |
else rem m n | |
where | |
rem :: Int -> Int -> Pool -> Pool | |
rem m n pool = | |
case fromJust $ Map.lookup m pool of | |
[] -> Map.delete m pool | |
lst -> Map.insert m (delete n lst) pool | |
presort :: [Piece] -> Pool | |
presort = foldr addPiece Map.empty | |
-- Tree of chains | |
-- Each node contains a port | |
-- and a list of smaller chains | |
-- Top node will contain port 0 | |
data Rose = NodeR Int [Rose] | |
deriving Show | |
-- Represent the tree as a fixed point of a functor | |
data TreeF a = NodeF Int [a] | |
deriving Functor | |
newtype Fix f = Fix { unFix :: f (Fix f) } | |
type Tree = Fix TreeF | |
type Coalgebra f a = a -> f a | |
-- This coalgebra builds a tree using anamorphism | |
coalg :: Coalgebra TreeF (Int, Pool) | |
coalg (n, pool) = | |
case Map.lookup n pool of | |
Nothing -> NodeF n [] | |
Just ms -> NodeF n [(m, removePiece (m, n) pool) | m <- ms] | |
ana :: Functor f => Coalgebra f a -> a -> Fix f | |
ana coalg = Fix . fmap (ana coalg) . coalg | |
type Algebra f a = f a -> a | |
-- This algebra is for testing | |
tAlg :: Algebra TreeF Rose | |
tAlg (NodeF n lst) = NodeR n lst | |
-- This algebra turns a tree into a list of chains | |
chainAlg :: Algebra TreeF (Int, [Chain]) | |
chainAlg (NodeF n []) = (n, []) | |
chainAlg (NodeF n lst) = (n, concat [push (n, m) bs | (m, bs) <- lst]) | |
where | |
push :: (Int, Int) -> [Chain] -> [Chain] | |
push (n, m) [] = [[(n, m)]] | |
push (n, m) bs = [(n, m) : br | br <- bs] | |
cata :: Functor f => Algebra f a -> Fix f -> a | |
cata alg = alg . fmap (cata alg) . unFix | |
hylo :: Functor f => Algebra f a -> Coalgebra f b -> b -> a | |
hylo f g = f . fmap (hylo f g) . g | |
score :: Chain -> Int | |
score = sum . fmap score1 | |
where score1 (m, n) = m + n | |
bestChain :: [Piece] -> [Chain] | |
bestChain pieces = | |
let pool = presort pieces | |
(_, chains) = hylo chainAlg coalg (0, pool) | |
-- in maximum $ fmap score chains | |
maxscore = maximum $ fmap score chains | |
in filter (\c -> score c == maxscore) chains | |
toPiece :: String -> Piece | |
toPiece s = let (a, b) = break (== '/') s | |
in (read a, read (tail b)) | |
test = ["0/2", | |
"2/2", | |
"2/3", | |
"3/4", | |
"3/5", | |
"0/1", | |
"10/1", | |
"9/10", | |
"5/7"] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment