]> Git — Sourcephile - literate-phylomemy-example1.git/blob - script.hs
init
[literate-phylomemy-example1.git] / script.hs
1 #!/usr/bin/env -S nix -L shell .#ghc .#ghcid .#xdot --command ghcid --test :main
2 -- Alternatively: #!/usr/bin/env -S nix -L shell .#ghc .#xdot --command runghc
3 -- SPDX-FileCopyrightText: 2024 Jane Doe <jane@example.org>
4 -- SPDX-License-Identifier: CC0-1.0
5 {-# LANGUAGE OverloadedLists #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE ParallelListComp #-}
8
9 import Control.Concurrent.Async qualified as Async
10 import Data.ByteString.Builder qualified as BS
11 import Data.Either (fromRight)
12 import Data.Map.Strict qualified as Map
13 import Data.Sequence qualified as Seq
14 import Logic
15 import Logic.Theory.Arithmetic
16 import Logic.Theory.Ord
17 import Numeric.Probability
18 import Phylomemy qualified as Phylo
19 import System.IO qualified as Sys
20 import System.Process qualified as Sys
21 import Text.Pretty.Simple
22
23 main = do
24 let minSupp = assertStrictlyPositive 1
25 let minSize = assertStrictlyPositive 2
26
27 letName rangeToDocs0 $ \rangeToDocs ->
28 letName ["a", "b", "c", "d", "e", "f", "g"] $ \roots -> do
29 let clusters =
30 Phylo.clusterize roots minSupp minSize rangeToDocs
31
32 let msf :: Phylo.MaximalSpanningForest Pos Phylo.Cluster =
33 Phylo.maximalSpanningForest Phylo.similarityJaccard (unName <$> clusters)
34 let phylomemy :: Phylo.MaximalSpanningForest Pos Phylo.Cluster =
35 let Just lambda = probability 0.3
36 in letName (Phylo.predictionMeasureF lambda) $ \predMeasure ->
37 Phylo.msfSplit predMeasure roots msf
38 let dot = Phylo.dotMaximalSpanningForest phylomemy
39
40 pPrint ("Number of maximal spanning trees", length phylomemy)
41 Sys.withFile "phylomemy.dot" Sys.WriteMode (`BS.hPutBuilder` dot)
42 Sys.callProcess "xdot" ["phylomemy.dot"]
43
44 rangeToDocs0 :: Pos Phylo.:-> Seq.Seq (Phylo.Document Pos)
45 rangeToDocs0 =
46 Map.fromList
47 [ ( Pos rangeIndex
48 , Seq.fromList
49 [ Phylo.Document
50 { Phylo.documentPosition = Pos (2 * rangeIndex + 3 * docIndex)
51 , Phylo.documentRoots = Map.fromList [(r, ()) | r <- roots]
52 }
53 | roots <- docs
54 | docIndex <- [1 ..]
55 ]
56 )
57 | docs <-
58 [ [["a", "b", "c"], ["a", "d", "e"], ["e", "f", "g"]]
59 , [["a", "b"], ["d", "f"]]
60 , [["f"], ["d", "f"], ["f", "g", "a"]]
61 , [["b", "c", "e"], ["a", "d", "e"], ["a", "b", "c"]]
62 , [["d", "f", "g"], ["b", "f"], ["a", "c", "d"], ["a", "f"]]
63 , [["c", "d", "g"], ["b", "c", "g"], ["a", "b", "c"], ["e", "g"]]
64 ]
65 | rangeIndex <- [1 ..]
66 ]
67
68 assertStrictlyPositive :: (Ord a) => (Zeroable a) => a -> () ::: a / () > Zero
69 assertStrictlyPositive i = unitName i Logic./ fromRight undefined (prove (unitName i Logic.Theory.Ord.> zero))
70
71 newtype Pos = Pos Int deriving (Eq, Ord, Show, Num)
72 instance Phylo.ShowHuman Pos where
73 showHuman (Pos x) = show x