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 #-}
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
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
24 let minSupp = assertStrictlyPositive 1
25 let minSize = assertStrictlyPositive 2
27 letName rangeToDocs0 $ \rangeToDocs ->
28 letName ["a", "b", "c", "d", "e", "f", "g"] $ \roots -> do
30 Phylo.clusterize roots minSupp minSize rangeToDocs
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
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"]
44 rangeToDocs0 :: Pos Phylo.:-> Seq.Seq (Phylo.Document Pos)
50 { Phylo.documentPosition = Pos (2 * rangeIndex + 3 * docIndex)
51 , Phylo.documentRoots = Map.fromList [(r, ()) | r <- roots]
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"]]
65 | rangeIndex <- [1 ..]
68 assertStrictlyPositive :: (Ord a) => (Zeroable a) => a -> () ::: a / () > Zero
69 assertStrictlyPositive i = unitName i Logic./ fromRight undefined (prove (unitName i Logic.Theory.Ord.> zero))
71 newtype Pos = Pos Int deriving (Eq, Ord, Show, Num)
72 instance Phylo.ShowHuman Pos where
73 showHuman (Pos x) = show x