Add distance function (#75)

* Add distance function

* Add distance measure for lists with testcases

* Add more distance measures for AST

* Add distance to commandline

* Fix distance always giving 0

6 files changed, 274 insertions, 49 deletions

diff --git a/src/Verismith.hs b/src/Verismith.hs
index c9d3e78..9dc3475 100644
--- a/src/Verismith.hs
+++ b/src/Verismith.hs
@@ -70,6 +70,7 @@ import           Verismith.Tool
 import           Verismith.Tool.Internal
 import           Verismith.Verilog
 import           Verismith.Verilog.Parser (parseSourceInfoFile)
+import Verismith.Verilog.Distance
 import Verismith.Utils (generateByteString)
 
 toFP :: String -> FilePath
@@ -216,6 +217,11 @@ handleOpts (ConfigOpt c conf r) = do
         $   T.unpack
         .   toTextIgnore
         <$> c
+handleOpts (DistanceOpt v1 v2) = do
+  src1 <- parseSourceInfoFile (T.pack v1) (toTextIgnore v1)
+  src2 <- parseSourceInfoFile (T.pack v2) (toTextIgnore v2)
+  let d = distance src1 src2
+  putStrLn ("Distance: " <> show d)
 
 defaultMain :: IO ()
 defaultMain = do
diff --git a/src/Verismith/OptParser.hs b/src/Verismith/OptParser.hs
index 592f9e9..19eb640 100644
--- a/src/Verismith/OptParser.hs
+++ b/src/Verismith/OptParser.hs
@@ -55,6 +55,9 @@ data Opts = Fuzz { fuzzOutput          :: Text
                       , configOptConfigFile  :: !(Maybe FilePath)
                       , configOptDoRandomise :: !Bool
                       }
+          | DistanceOpt { distanceOptVerilogA :: !FilePath
+                        , distanceOptVerilogB :: !FilePath
+                        }
 
 textOption :: Mod OptionFields String -> Parser Text
 textOption = fmap T.pack . Opt.strOption
@@ -234,61 +237,63 @@ configOpts =
                    "Randomise the given default config, or the default config by randomly switchin on and off options."
             )
 
+distanceOpts :: Parser Opts
+distanceOpts =
+  DistanceOpt
+  <$> (fromText . T.pack <$> Opt.strArgument
+        (Opt.metavar "FILE" <> Opt.help "First verilog file."))
+  <*> (fromText . T.pack <$> Opt.strArgument
+        (Opt.metavar "FILE" <> Opt.help "Second verilog file."))
+
 argparse :: Parser Opts
 argparse =
     Opt.hsubparser
-            (  Opt.command
-                    "fuzz"
-                    (Opt.info
-                        fuzzOpts
-                        (Opt.progDesc
-                            "Run fuzzing on the specified simulators and synthesisers."
-                        )
-                    )
-            <> Opt.metavar "fuzz"
-            )
+            (Opt.command
+              "fuzz"
+              (Opt.info
+                fuzzOpts
+                (Opt.progDesc
+                  "Run fuzzing on the specified simulators and synthesisers."))
+              <> Opt.metavar "fuzz")
         <|> Opt.hsubparser
-                (  Opt.command
-                        "generate"
-                        (Opt.info
-                            genOpts
-                            (Opt.progDesc "Generate a random Verilog program.")
-                        )
-                <> Opt.metavar "generate"
-                )
+                (Opt.command
+                  "generate"
+                  (Opt.info
+                    genOpts
+                    (Opt.progDesc "Generate a random Verilog program."))
+                  <> Opt.metavar "generate")
         <|> Opt.hsubparser
-                (  Opt.command
+                (Opt.command
                         "parse"
                         (Opt.info
-                            parseOpts
-                            (Opt.progDesc
-                                "Parse a verilog file and output a pretty printed version."
-                            )
-                        )
-                <> Opt.metavar "parse"
-                )
+                          parseOpts
+                          (Opt.progDesc
+                            "Parse a verilog file and output a pretty printed version."))
+                  <> Opt.metavar "parse")
         <|> Opt.hsubparser
-                (  Opt.command
-                        "reduce"
-                        (Opt.info
-                            reduceOpts
-                            (Opt.progDesc
-                                "Reduce a Verilog file by rerunning the fuzzer on the file."
-                            )
-                        )
-                <> Opt.metavar "reduce"
-                )
+                (Opt.command
+                 "reduce"
+                  (Opt.info
+                    reduceOpts
+                    (Opt.progDesc
+                      "Reduce a Verilog file by rerunning the fuzzer on the file."))
+                  <> Opt.metavar "reduce")
         <|> Opt.hsubparser
-                (  Opt.command
-                        "config"
-                        (Opt.info
-                            configOpts
-                            (Opt.progDesc
-                                "Print the current configuration of the fuzzer."
-                            )
-                        )
-                <> Opt.metavar "config"
-                )
+                (Opt.command
+                  "config"
+                  (Opt.info
+                    configOpts
+                    (Opt.progDesc
+                      "Print the current configuration of the fuzzer."))
+                  <> Opt.metavar "config")
+         <|> Opt.hsubparser
+                (Opt.command
+                  "distance"
+                  (Opt.info
+                    distanceOpts
+                    (Opt.progDesc
+                      "Calculate the distance between two different pieces of Verilog."))
+                  <> Opt.metavar "distance")
 
 version :: Parser (a -> a)
 version = Opt.infoOption versionInfo $ mconcat
@@ -297,8 +302,7 @@ version = Opt.infoOption versionInfo $ mconcat
 opts :: ParserInfo Opts
 opts = Opt.info
     (argparse <**> Opt.helper <**> version)
-    (  Opt.fullDesc
+    (Opt.fullDesc
     <> Opt.progDesc "Fuzz different simulators and synthesisers."
     <> Opt.header
-           "Verismith - A hardware simulator and synthesiser Verilog fuzzer."
-    )
+           "Verismith - A hardware simulator and synthesiser Verilog fuzzer.")
diff --git a/src/Verismith/Verilog/Distance.hs b/src/Verismith/Verilog/Distance.hs
new file mode 100644
index 0000000..edc24f5
--- /dev/null
+++ b/src/Verismith/Verilog/Distance.hs
@@ -0,0 +1,181 @@
+{-|
+Module      : Verismith.Verilog.Distance
+Description : Definition of the distance function for the abstract syntax tree.
+Copyright   : (c) 2020, Yann Herklotz
+License     : GPL-3
+Maintainer  : yann [at] yannherklotz [dot] com
+Stability   : experimental
+Poratbility : POSIX
+
+Define the distance function for the abstract syntax tree, so that different
+Verilog files can be compared.  This allows us to define a metric on how
+different two pieces of Verilog are.  Currently, differences in expressions are
+ignored, as these are not that interesting.
+-}
+
+module Verismith.Verilog.Distance where
+
+import Verismith.Verilog.AST
+import Verismith.Verilog.Eval
+import Data.Functor.Foldable (cata)
+import Data.Text (Text, unpack)
+
+data Pair a b = Pair a b
+  deriving Show
+
+instance Eq b => Eq (Pair a b) where
+  Pair _ a == Pair _ b = a == b
+
+instance Ord b => Ord (Pair a b) where
+  Pair _ a <= Pair _ b = a <= b
+
+eqDistance :: Eq a => a -> a -> Int
+eqDistance a b = if a == b then 0 else 1
+{-# INLINE eqDistance #-}
+
+emptyDistance :: a -> a -> Int
+emptyDistance _ _ = 0
+{-# INLINE emptyDistance #-}
+
+class Distance a where
+  distance :: a -> a -> Int
+  udistance :: a -> a -> Int
+  udistance = distance
+  dempty :: a -> Int
+  dempty _ = 1
+
+minimumloc :: Distance a => a -> [a] -> Pair Int Int
+minimumloc ah [] = Pair 0 $ dempty ah
+minimumloc ah b = minimum $ (\(loc, el) -> Pair loc (udistance ah el)) <$> zip [0..] b
+
+removeAt :: Int -> [a] -> [a]
+removeAt loc lst =
+  let (a, b) = splitAt loc lst in
+    if null b then a else a ++ tail b
+
+remdist :: Distance a => [a] -> [a] -> Int
+remdist [] a = distance [] a
+remdist a [] = distance [] a
+remdist (x:xs) b
+  | cost <= dx = udistance xs (removeAt loc b) + cost
+  | otherwise = udistance xs b + dx
+  where
+    Pair loc cost = minimumloc x b
+    dx = dempty x
+
+instance Distance a => Distance [a] where
+  distance [] [] = 0
+  distance [] l = sum $ dempty <$> l
+  distance l [] = sum $ dempty <$> l
+  distance a@(ah:at) b@(bh:bt) =
+    let cost = distance ah bh in
+      if cost == 0 then
+        distance at bt
+      else
+        minimum [ distance at b + dempty ah
+                , distance bt a + dempty bh
+                , distance at bt + cost
+                ]
+
+  udistance a b = minimum [ remdist a b
+                          , remdist b a
+                          ]
+
+  dempty [] = 0
+  dempty (a:b) = maximum [dempty a, dempty b]
+
+instance Distance a => Distance (Maybe a) where
+  distance Nothing a = dempty a
+  distance a Nothing = dempty a
+  distance (Just a) (Just b) = distance a b
+
+  udistance (Just a) (Just b) = udistance a b
+  udistance a b = distance a b
+
+  dempty Nothing = 0
+  dempty (Just a) = dempty a
+
+instance Distance Char where
+  distance = eqDistance
+
+instance Distance Bool where
+  distance = eqDistance
+
+instance Distance Integer where
+  distance = eqDistance
+
+instance Distance Text where
+  distance t1 t2 = distance (unpack t1) (unpack t2)
+
+instance Distance Identifier where
+  distance = eqDistance
+
+eval :: ConstExpr -> Integer
+eval c = toInteger (cata (evaluateConst []) c)
+
+instance Distance ConstExpr where
+  distance c1 c2 = distance (eval c1) $ eval c2
+  udistance c1 c2 = udistance (eval c1) $ eval c2
+
+instance Distance Parameter where
+  distance _ _ = 0
+
+instance Distance PortType where
+  distance = eqDistance
+
+instance Distance PortDir where
+  distance = eqDistance
+
+instance Distance (Statement a) where
+  distance (TimeCtrl _ s1) (TimeCtrl _ s2) = distance s1 s2
+  distance (EventCtrl _ s1) (EventCtrl _ s2) = distance s1 s2
+  distance (SeqBlock s1) (SeqBlock s2) = distance s1 s2
+  distance (CondStmnt _ st1 sf1) (CondStmnt _ st2 sf2) = distance st1 st2 + distance sf1 sf2
+  distance (ForLoop _ _ _ s1) (ForLoop _ _ _ s2) = distance s1 s2
+  distance (StmntAnn _ s1) s2 = distance s1 s2
+  distance (BlockAssign _) (BlockAssign _) = 0
+  distance (NonBlockAssign _) (NonBlockAssign _) = 0
+  distance (TaskEnable _) (TaskEnable _) = 0
+  distance (SysTaskEnable _) (SysTaskEnable _) = 0
+  distance (StmntCase _ _ _ _) (StmntCase _ _ _ _) = 0
+  distance _ _ = 1
+
+instance Distance (ModItem a) where
+  distance (ModCA _) (ModCA _) = 0
+  distance (ModInst _ _ _) (ModInst _ _ _) = 0
+  distance (Initial _) (Initial _) = 0
+  distance (Always s1) (Always s2) = distance s1 s2
+  distance (Decl _ _ _) (Decl _ _ _) = 0
+  distance (ParamDecl _) (ParamDecl _) = 0
+  distance (LocalParamDecl _) (LocalParamDecl _) = 0
+  distance _ _ = 1
+
+instance Distance Range where
+  distance (Range a1 b1) (Range a2 b2) =
+    distance a1 a2 + distance b1 b2
+  udistance (Range a1 b1) (Range a2 b2) =
+    udistance a1 a2 + udistance b1 b2
+
+instance Distance Port where
+  distance (Port t1 s1 r1 _) (Port t2 s2 r2 _) =
+    distance t1 t2 + distance s1 s2 + distance r1 r2
+  udistance (Port t1 s1 r1 _) (Port t2 s2 r2 _) =
+    udistance t1 t2 + udistance s1 s2 + udistance r1 r2
+  dempty (Port t1 s1 r1 _) = 1 + dempty t1 + dempty s1 + dempty r1
+
+instance Distance (ModDecl a) where
+  distance (ModDecl _ min1 mout1 mis1 mp1) (ModDecl _ min2 mout2 mis2 mp2) =
+    distance min1 min2 + distance mout1 mout2 + distance mis1 mis2 + distance mp1 mp2
+  udistance (ModDecl _ min1 mout1 mis1 mp1) (ModDecl _ min2 mout2 mis2 mp2) =
+    udistance min1 min2 + udistance mout1 mout2 + udistance mis1 mis2 + udistance mp1 mp2
+  dempty (ModDecl _ min mout mis mp) = 1 + dempty min + dempty mout + dempty mis + dempty mp
+
+instance Distance (Verilog a) where
+  distance (Verilog m1) (Verilog m2) = distance m1 m2
+  udistance (Verilog m1) (Verilog m2) = udistance m1 m2
+  dempty (Verilog m) = 1 + dempty m
+
+instance Distance (SourceInfo a) where
+  distance (SourceInfo _ v1) (SourceInfo _ v2) = distance v1 v2
+  udistance (SourceInfo _ v1) (SourceInfo _ v2) = udistance v1 v2
+  dempty (SourceInfo _ v) = 1 + dempty v
diff --git a/test/Distance.hs b/test/Distance.hs
new file mode 100644
index 0000000..a59b401
--- /dev/null
+++ b/test/Distance.hs
@@ -0,0 +1,30 @@
+module Distance
+  ( distanceTests
+  )
+where
+
+import Hedgehog (Property, (===))
+import qualified Hedgehog as Hog
+import qualified Hedgehog.Gen as Hog
+import qualified Hedgehog.Range as Hog
+import Verismith.Verilog.Distance
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+distanceLess :: Property
+distanceLess = Hog.property $ do
+  x <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)
+  y <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)
+  Hog.assert $ udistance x y <= distance x y
+
+distanceEq :: Property
+distanceEq = Hog.property $ do
+  x <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)
+  distance x x === 0
+  udistance x x === 0
+
+distanceTests :: TestTree
+distanceTests = testGroup "Distance tests"
+  [ testProperty "Unordered distance <= distance" distanceLess
+  , testProperty "distance x x === 0" distanceEq
+  ]
diff --git a/test/Property.hs b/test/Property.hs
index 7e1911e..64f9bc6 100644
--- a/test/Property.hs
+++ b/test/Property.hs
@@ -26,6 +26,7 @@ import           Verismith
 import           Verismith.Result
 import           Verismith.Verilog.Lex
 import           Verismith.Verilog.Parser
+import Distance (distanceTests)
 
 randomDAG' :: Gen Circuit
 randomDAG' = Hog.resize 30 randomDAG
@@ -48,4 +49,5 @@ propertyTests = testGroup
     "Property Tests"
     [ testProperty "acyclic graph generation check" acyclicGraph
     , parserTests
+    , distanceTests
     ]
diff --git a/verismith.cabal b/verismith.cabal
index 42a785b..35369b0 100644
--- a/verismith.cabal
+++ b/verismith.cabal
@@ -64,6 +64,7 @@ library
                  , Verismith.Verilog.AST
                  , Verismith.Verilog.BitVec
                  , Verismith.Verilog.CodeGen
+                 , Verismith.Verilog.Distance
                  , Verismith.Verilog.Eval
                  , Verismith.Verilog.Internal
                  , Verismith.Verilog.Lex
@@ -133,6 +134,7 @@ test-suite test
                , Property
                , Reduce
                , Parser
+               , Distance
   build-depends: base >=4 && <5
                , verismith
                , fgl >=5.6 && <5.8