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
6 {-# LANGUAGE OverloadedLists #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE ParallelListComp #-}
10 import Control.Concurrent.Async qualified as Async
11 import Data.ByteString.Builder qualified as BS
12 import Data.Either (fromRight)
13 import Data.Map.Strict qualified as Map
14 import Data.Sequence qualified as Seq
16 import Logic.Theory.Arithmetic
17 import Logic.Theory.Ord
18 import Numeric.Probability
19 import Phylomemy qualified as Phylo
20 import System.IO qualified as Sys
21 import System.Process qualified as Sys
22 import Text.Pretty.Simple
26 assertStrictlyPositive :: Ord a => Zeroable a => a -> () ::: a / () > Zero
27 assertStrictlyPositive i = unitName i Logic./ fromRight undefined (prove (unitName i Logic.Theory.Ord.> zero))
34 Logic.letName rangeToDocs0 $ \rangeToDocs ->
35 Logic.letName ["a", "b", "c", "d", "e", "F", "g"] $ \roots ->
36 Phylo.clusterize roots (assertStrictlyPositive minSupp) (assertStrictlyPositive minSize) rangeToDocs
38 let phy = Phylo.phylomemy Phylo.jaccardSimilarity (unName <$> clusters)
39 let dot = Phylo.phylomemyDOT phy
40 let msf :: Map.Map (Pos, Phylo.Cluster) (Phylo.MST Pos)
41 = Phylo.branchesMSF phy
43 pPrint ("msf", Map.size msf)
44 Sys.withFile "phylomemy.dot" Sys.WriteMode (`BS.hPutBuilder` dot)
45 Sys.callProcess "xdot" ["phylomemy.dot"]
47 phy :: Phylo.PhylomemyDownstream Int
51 newtype Pos = Pos Int deriving (Eq, Ord, Show, Num)
53 rangeToDocs0 :: Pos Phylo.:-> Seq.Seq (Phylo.Document Pos)
59 { Phylo.documentPosition = Pos (2 * rangeIndex + 3 * docIndex)
60 , Phylo.documentRoots = Map.fromList [(r, ()) | r <- roots]
67 [ [["a", "b", "c"], ["a", "d", "e"], ["e", "f", "g"]]
68 , [["a", "b"], ["d", "f"]]
69 , [["f"], ["d", "f"], ["f", "g", "a"]]
70 , [["b", "c", "e"], ["a", "d", "e"], ["a", "b", "c"]]
71 , [["d", "f", "g"], ["b", "f"], ["a", "c", "d"], ["a", "f"]]
72 , [["c", "d", "g"], ["b", "c", "g"], ["a", "b", "c"], ["e", "g"]]
74 | rangeIndex <- [1 ..]