MESSAGE
| DATE | 2016-11-02 |
| FROM | Ruben Safir
|
| SUBJECT | Re: [Learn] Fitch Algorithm - C++
|
From learn-bounces-at-nylxs.com Wed Nov 2 22:43:53 2016
Return-Path:
X-Original-To: archive-at-mrbrklyn.com
Delivered-To: archive-at-mrbrklyn.com
Received: from www.mrbrklyn.com (www.mrbrklyn.com [96.57.23.82])
by mrbrklyn.com (Postfix) with ESMTP id B0629161312;
Wed, 2 Nov 2016 22:43:53 -0400 (EDT)
X-Original-To: learn-at-nylxs.com
Delivered-To: learn-at-nylxs.com
Received: from mailbackend.panix.com (mailbackend.panix.com [166.84.1.89])
by mrbrklyn.com (Postfix) with ESMTP id B13E3160E77
for ; Wed, 2 Nov 2016 22:43:51 -0400 (EDT)
Received: from [10.0.0.62] (www.mrbrklyn.com [96.57.23.82])
by mailbackend.panix.com (Postfix) with ESMTPSA id DD65019F0F
for ; Wed, 2 Nov 2016 22:43:50 -0400 (EDT)
To: learn-at-nylxs.com
References: <20161102182751.GA10998-at-www.mrbrklyn.com>
<87k2cl7184.fsf-at-contrapunctus.net>
From: Ruben Safir
Message-ID: <2ab889a4-74bd-7670-b872-04bb8af301ce-at-panix.com>
Date: Wed, 2 Nov 2016 22:43:50 -0400
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101
Thunderbird/45.4.0
MIME-Version: 1.0
In-Reply-To: <87k2cl7184.fsf-at-contrapunctus.net>
Subject: Re: [Learn] Fitch Algorithm - C++
X-BeenThere: learn-at-nylxs.com
X-Mailman-Version: 2.1.17
Precedence: list
List-Id:
List-Unsubscribe: ,
List-Archive:
List-Post:
List-Help:
List-Subscribe: ,
Content-Type: text/plain; charset="windows-1252"
Content-Transfer-Encoding: quoted-printable
Errors-To: learn-bounces-at-nylxs.com
Sender: "Learn"
On 11/02/2016 10:20 PM, Christopher League wrote:
> Tonight I put together a small Haskell script for the Fitch algorithm.
> You specify a tree with its leaves labeled, and it figures out the
> labels for the interior nodes. There are no transition weights. It
> outputs the tree in GraphViz format, so we use |dot| to generate the
> image=85 see attached.
> =
I knew you were going to go impatient and do that.
> |{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TupleSections #-}
> import Data.List (intersperse) import Data.Set (Set) import
> Control.Monad.State import Control.Monad.Writer import qualified
> Data.Set as Set data Tree a b =3D Leaf {leafValue :: b } | Branch
> {branchValue :: a ,branchLeft :: Tree a b ,branchRight :: Tree a b }
> deriving Show value :: Tree a a -> a value (Leaf a) =3D a value (Branch a
> _ _) =3D a -- Bottom up phase1 :: Ord b =3D> Tree a b -> (Set b, Tree (Set
> b) b) phase1 (Leaf b) =3D (Set.singleton b, Leaf b) phase1 (Branch _ l r)
> =3D (s3, Branch s3 l' r') where (s1, l') =3D phase1 l (s2, r') =3D phase1=
r s3
> =3D if Set.null i then u else i where u =3D Set.union s1 s2 i =3D
> Set.intersection s1 s2 -- Top down phase2 :: Ord b =3D> Tree (Set b) b ->
> Maybe b -> Tree b b phase2 (Leaf b) _ =3D Leaf b phase2 (Branch set left
> right) parentOpt =3D Branch b (phase2 left (Just b)) (phase2 right (Just
> b)) where b =3D case parentOpt of Just p | Set.member p set -> p _ ->
> Set.elemAt 0 set -- Combine them together fitch :: Ord b =3D> Tree a b ->
> Tree b b fitch t =3D phase2 t' Nothing where (_, t') =3D phase1 t
> ------------------------------------------------------------------ --
> This part is about visualizing the trees using GraphViz (dot) class
> ToLabel a where toLabel :: a -> String instance ToLabel Char where
> toLabel c =3D [c] instance ToLabel String where toLabel =3D id instance
> ToLabel a =3D> ToLabel (Set a) where toLabel s =3D "{" ++ concat
> (intersperse "," (map toLabel (Set.toList s))) ++ "}" next :: State Int
> Int next =3D get <* modify (+1) numberTree :: Tree a b -> State Int (Tree
> (Int,a) (Int,b)) numberTree (Leaf b) =3D Leaf . (,b) <$> next numberTree
> (Branch a l r) =3D Branch . (,a) <$> next <*> numberTree l <*> numberTree
> r graphViz' :: (ToLabel a, ToLabel b) =3D> Tree (Int,a) (Int,b) -> Writer
> String String graphViz' (Leaf (i,b)) =3D do let n =3D "n" ++ show i tell =
$ n
> ++ " [shape=3Dbox, label=3D\"" ++ toLabel b ++ "\"]\n" return n graphViz'
> (Branch (i,a) l r) =3D do n1 <- graphViz' l n2 <- graphViz' r let np =3D =
"n"
> ++ show i tell $ np ++ " [shape=3Doval, label=3D\"" ++ toLabel a ++ "\"]\=
n"
> tell $ np ++ " -> " ++ n1 ++ "\n" tell $ np ++ " -> " ++ n2 ++ "\n"
> return np graphViz :: (ToLabel a, ToLabel b) =3D> Tree a b -> String
> graphViz t =3D "digraph{\n" ++ execWriter (graphViz' t') ++ "}\n" where t'
> =3D evalState (numberTree t) 0 -- Sample tree from
> http://www.cse.nd.edu/~cse/2013fa/40532/lectures/lecture23/lecture23.pdf
> t1 :: Tree () Char t1 =3D Branch () ( Branch () ( Branch () (Leaf 'C')
> (Leaf 'G') ) ( Branch () (Leaf 'T') (Leaf 'G') ) ) (Leaf 'A') main :: IO
> () main =3D putStrLn $ graphViz $ fitch t1|
> =
> =
> =
> _______________________________________________
> Learn mailing list
> Learn-at-nylxs.com
> http://lists.mrbrklyn.com/mailman/listinfo/learn
> =
-- =
So many immigrant groups have swept through our town
that Brooklyn, like Atlantis, reaches mythological
proportions in the mind of the world - RI Safir 1998
http://www.mrbrklyn.com
DRM is THEFT - We are the STAKEHOLDERS - RI Safir 2002
http://www.nylxs.com - Leadership Development in Free Software
http://www2.mrbrklyn.com/resources - Unpublished Archive
http://www.coinhangout.com - coins!
http://www.brooklyn-living.com
Being so tracked is for FARM ANIMALS and and extermination camps,
but incompatible with living as a free human being. -RI Safir 2013
_______________________________________________
Learn mailing list
Learn-at-nylxs.com
http://lists.mrbrklyn.com/mailman/listinfo/learn
|
|
