From 88a045ab80f3e8c941db23f3370b436f87bb689b Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 2 Feb 2025 12:22:22 -0800 Subject: [PATCH 01/32] Gitignore --- .gitignore | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f94ebc4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +copilot-profiling +.DS_Store +.log From fcfd2e4896b9321333e4f5ad998c7b15c05cd9b4 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 2 Feb 2025 12:22:57 -0800 Subject: [PATCH 02/32] Initial prototype. This commit introduces a new library, copilot-visualizer, that produces a tikz diagram from a Copilot spec. The library leverages the interpreter, so externs must contain enough samples for the visualization to take place. Co-authored-by: Frank Dedden --- CHANGELOG | 0 LICENSE | 29 ++++++++ README.md | 34 +++++++++ Setup.hs | 2 + copilot-visualizer.cabal | 51 +++++++++++++ src/Copilot/Visualize.hs | 153 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 269 insertions(+) create mode 100644 CHANGELOG create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 copilot-visualizer.cabal create mode 100644 src/Copilot/Visualize.hs diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..e69de29 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d4ed5bc --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +2009 +BSD3 License terms + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of the developers nor the names of its contributors +may be used to endorse or promote products derived from this software +without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..f4a93c4 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) + +# Copilot: a stream DSL + +The visualizer, which draws Copilot specifications using different graphical +formats. + +Copilot is a runtime verification framework written in Haskell. It allows the +user to write programs in a simple but powerful way using a stream-based +approach. + +Programs can be interpreted for testing (with the library copilot-interpreter), +or translated C99 code to be incorporated in a project, or as a standalone +application. The C99 backend ensures us that the output is constant in memory +and time, making it suitable for systems with hard realtime requirements. + +## Installation + +Copilot-visualizer can be found on +[Hackage](https://hackage.haskell.org/package/copilot-interpreter). It is +typically only installed as part of the complete Copilot distribution. For +installation instructions, please refer to the [Copilot +website](https://copilot-language.github.io). + +## Further information + +For further information, install instructions and documentation, please visit +the Copilot website: +[https://copilot-language.github.io](https://copilot-language.github.io) + +## License + +Copilot is distributed under the BSD-3-Clause license, which can be found +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-interpreter/LICENSE). diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/copilot-visualizer.cabal b/copilot-visualizer.cabal new file mode 100644 index 0000000..e6b74c1 --- /dev/null +++ b/copilot-visualizer.cabal @@ -0,0 +1,51 @@ +cabal-version: >=1.10 +name: copilot-visualizer +version: 4.2 +synopsis: Visualizer for Copilot. +description: + Visualizer for Copilot. + . + Copilot is a stream (i.e., infinite lists) domain-specific language (DSL) in + Haskell that compiles into embedded C. Copilot contains an interpreter, + multiple back-end compilers, and other verification tools. + . + A tutorial, examples, and other information are available at + . + +author: Ivan Perez, Frank Dedden +license: BSD3 +license-file: LICENSE +maintainer: Ivan Perez +homepage: https://copilot-language.github.io +bug-reports: https://github.com/Copilot-Language/copilot/issues +stability: Experimental +category: Language, Embedded +build-type: Simple +extra-source-files: README.md, CHANGELOG + +x-curation: uncurated + +source-repository head + type: git + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-visualizer + +library + + default-language: Haskell2010 + + hs-source-dirs: src + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + pretty >= 1.0 && < 1.2, + + copilot-core >= 4.2 && < 4.3, + copilot-interpreter >= 4.2 && < 4.3 + + exposed-modules: + + Copilot.Visualize diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs new file mode 100644 index 0000000..574f0d7 --- /dev/null +++ b/src/Copilot/Visualize.hs @@ -0,0 +1,153 @@ +-- | Graphical visualization of Copilot specifications. + +{-# LANGUAGE Safe #-} + +module Copilot.Visualize + ( paint ) + where + +import Data.Maybe (isNothing, isJust) +import Data.List +import Copilot.Core +import Copilot.Interpret.Eval +import Text.Printf +import Text.Read + +paint :: Int -- ^ Number of steps to interpret. + -> Spec -- ^ Specification to interpret. + -> IO () +paint k spec = + paintEvaluation k spec e + where + e = eval Haskell k spec + +paintEvaluation :: Int + -> Spec + -> ExecTrace + -> IO () +paintEvaluation k spec e = do + putStrLn "\\documentclass{standalone}" + putStrLn "\\usepackage{tikz}" + putStrLn "\\usepackage{tikz-timing}" + putStrLn "\\usepackage{xcolor}" + putStrLn "\\definecolor{false}{HTML}{ECD9ED}" + putStrLn "\\definecolor{true}{HTML}{D9ECED}" + putStrLn "\\begin{document}" + putStrLn "\\tikzset{" + putStrLn "every picture/.style={" + putStrLn " execute at end picture={" + putStrLn " \\path (current bounding box.south west) +(-1,-1) (current bounding box.north east) +(1,1);" + putStrLn " }" + putStrLn "}" + putStrLn "}" + putStrLn "" + putStrLn "\\tikzset{" + putStrLn "timing/.style={x=5ex,y=2ex}," + putStrLn "timing/rowdist=4ex," + putStrLn "timing/dslope=0.1," + putStrLn "x=5ex," + putStrLn "timing/coldist=1ex," + putStrLn "timing/name/.style={font=\\sffamily\\scriptsize}," + putStrLn "timing/d/text/.style={font=\\sffamily\\tiny}," + putStrLn "}" + putStrLn "\\begin{tikztimingtable}" + printObserverOutputs + printTriggerOutputs + putStrLn "\\extracode" + putStrLn "\\begin{background}[shift={(0.05,0)},help lines]" + putStrLn $ "\\vertlines[help lines,opacity=0.3]{-0.3ex,...," + ++ show (k - 1) + ++ "}" + putStrLn "\\end{background}" + putStrLn "\\end{tikztimingtable}" + putStrLn "\\end{document}" + where + signal :: String -> [String] -> String + signal name values = name <> " & g" <> concat values <> "\\\\" + + printTriggerOutputs :: IO () + printTriggerOutputs = mapM_ putStrLn (map printTriggerOutput trigs) + where + printTriggerOutput :: (String, [Maybe [Output]], Int) -> String + printTriggerOutput (name, ls, argsLength) = + signal name trig + <> + "\n" + <> + concatMap (\(v, n) -> signal n (showValues v)) (zip (args argsLength) argNames) + where + trig :: [String] + trig = concatMap printTriggerOutputListElem ls + + args :: Int -> [[Maybe Output]] + args argsLength = transpose $ transMaybes ls argsLength + + argNames = [name <> " arg \\#" <> show n | n <- [0..]] + + -- Push Maybe's to inner level. + transMaybes :: [Maybe [Output]] -> Int -> [[Maybe Output]] + transMaybes [] _ = [] + transMaybes (xs:xss) argsLength = case xs of + Just xs' -> map Just xs' : transMaybes xss argsLength + Nothing -> replicate argsLength Nothing : transMaybes xss argsLength + + -- Ignores the value, just interprets as a boolean + printTriggerOutputListElem :: Maybe [Output] -> [String] + printTriggerOutputListElem Nothing = ["[fill=false]D{F}"] + printTriggerOutputListElem (Just _) = ["[fill=true]D{T}"] + + --------------------------------------------------------------------------- + printObserverOutputs :: IO () + printObserverOutputs = mapM_ putStrLn (map observerOutput obsvs) + where + observerOutput (name, ls) = signal name (showValues $ map Just ls) + + --------------------------------------------------------------------------- + showValues :: [Maybe String] -> [String] + showValues = map showValue + + showValue :: Maybe String -> String + showValue Nothing = "S" + showValue (Just s) | isBoolean s = showValueBoolean s + | isFloat s = showValueFloat s + | otherwise = showValueNumber s + + showValueBoolean :: String -> String + showValueBoolean "true" = "[fill=true]D{T}" + showValueBoolean "false" = "[fill=false]D{F}" + + showValueFloat :: String -> String + showValueFloat = formatFloat . read + where + formatFloat :: Double -> String + formatFloat = printf "D{%.2g}" + + showValueNumber :: String -> String + showValueNumber n = "D{" <> n <> "}" + --------------------------------------------------------------------------- + + trigs :: [(String, [Maybe [Output]], Int)] + trigs = map addArgsLength (interpTriggers e) + where + addArgsLength :: (String, [Maybe [Output]]) -> (String, [Maybe [Output]], Int) + addArgsLength (name, output) = (name, output, argsLength) + where + argsLength = case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t + + obsvs :: [(String, [Output])] + obsvs = interpObservers e + +isBoolean "true" = True +isBoolean "false" = True +isBoolean _ = False + +isFloat s = + isJust asInt || isNothing asFloat + where + asInt :: Maybe Int + asInt = readMaybe s + + asFloat :: Maybe Float + asFloat = readMaybe s From 1fb204837dd094e3f472469fada33fc1e5b9e27e Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Thu, 13 Feb 2025 18:28:49 -0800 Subject: [PATCH 03/32] WIP: Create an aeson struct. --- copilot-visualizer.cabal | 6 +- src/Copilot/Visualize.hs | 126 ++++++++++++++++++++++++++++++++++++++- 2 files changed, 127 insertions(+), 5 deletions(-) diff --git a/copilot-visualizer.cabal b/copilot-visualizer.cabal index e6b74c1..4647a1a 100644 --- a/copilot-visualizer.cabal +++ b/copilot-visualizer.cabal @@ -40,8 +40,10 @@ library -Wall build-depends: - base >= 4.9 && < 5, - pretty >= 1.0 && < 1.2, + base >= 4.9 && < 5, + aeson, + pretty >= 1.0 && < 1.2, + ogma-extra >= 1.6.0 && < 1.7, copilot-core >= 4.2 && < 4.3, copilot-interpreter >= 4.2 && < 4.3 diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 574f0d7..d20f610 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -1,18 +1,138 @@ -- | Graphical visualization of Copilot specifications. -{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} module Copilot.Visualize - ( paint ) where -import Data.Maybe (isNothing, isJust) +import Data.Aeson +import Data.Maybe (isNothing, isJust, fromMaybe) import Data.List import Copilot.Core import Copilot.Interpret.Eval +import GHC.Generics import Text.Printf import Text.Read +data TraceElem = TraceElem + { teName :: String + , teIsBoolean :: Bool + , teIsFloat :: Bool + , teValues :: [ String ] + } + deriving (Generic, Show) + +instance ToJSON TraceElem + +type Trace = [ TraceElem ] + +makeTrace :: Int -- ^ Number of steps to interpret. + -> Spec -- ^ Specification to interpret. + -> IO () +makeTrace k spec = + print $ toJSON $ makeTraceEval k spec e + where + e = eval Haskell k spec + +makeTraceEval :: Int + -> Spec + -> ExecTrace + -> Trace +makeTraceEval k spec e = + observerTEs ++ triggerTEs + where + observerTEs = map observerTE obsvs + + triggerTEs = concatMap triggerTE trigs + + observerTE :: (String, [Output]) -> TraceElem + observerTE (name, outputs) = TraceElem + { teName = name + , teIsBoolean = boolean + , teIsFloat = float + , teValues = outputs + } + where + boolean = case outputs of + [] -> False + (x:_) -> isBoolean x + + float = case outputs of + [] -> False + (x:_) -> isFloat x + + triggerTE :: (String, [[String]]) -> [TraceElem] + triggerTE (name, ls) = + map triggerArgTE (zip ls [0..]) + where + triggerArgTE (values, i) = + TraceElem { teName = name ++ " # " ++ show i + , teIsBoolean = boolean + , teIsFloat = float + , teValues = values + } + where + boolean = case values of + [] -> False + (x:_) -> isBoolean x + + float = case values of + [] -> False + (x:_) -> isFloat x + + trigs :: [(String, [[String]])] + trigs = map (printOutputs . regroup) trigs' + where + printOutputs :: (String, [[Maybe Output]]) -> (String, [[String]]) + printOutputs (nm, ls) = (nm, transpose $ map (map ppTriggerOutput) ls) + + ppTriggerOutput :: Maybe Output -> String + ppTriggerOutput Nothing = "--" + ppTriggerOutput (Just v) = v + + regroup :: (String, [Maybe [Output]], Int) -> (String, [[Maybe Output]]) + regroup (n, ls, len) = (n, map rep ls) + where + rep :: Maybe [a] -> [Maybe a] + rep Nothing = replicate len Nothing + rep (Just x) = map Just x + + trigs' :: [(String, [Maybe [Output]], Int)] + trigs' = map addArgsLength (interpTriggers e) + where + addArgsLength :: (String, [Maybe [Output]]) -> (String, [Maybe [Output]], Int) + addArgsLength (name, output) = (name, output, argsLength) + where + argsLength = case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t + +-- printTriggerOutput :: (String, [Maybe [Output]], Int) -> TraceElem +-- printTriggerOutput (name, ls, argsLength) = +-- signal name trig +-- <> +-- "\n" +-- <> +-- concatMap (\(v, n) -> signal n (showValues v)) (zip (args argsLength) argNames) +-- where +-- trig :: [String] +-- trig = concatMap printTriggerOutputListElem ls +-- +-- args :: Int -> [[Maybe Output]] +-- args argsLength = transpose $ transMaybes ls argsLength +-- +-- argNames = [name <> " arg \\#" <> show n | n <- [0..]] + + -- Push Maybe's to inner level. + transMaybes :: [Maybe [Output]] -> Int -> [[Maybe Output]] + transMaybes [] _ = [] + transMaybes (xs:xss) argsLength = case xs of + Just xs' -> map Just xs' : transMaybes xss argsLength + Nothing -> replicate argsLength Nothing : transMaybes xss argsLength + + obsvs :: [(String, [Output])] + obsvs = interpObservers e + paint :: Int -- ^ Number of steps to interpret. -> Spec -- ^ Specification to interpret. -> IO () From ec28a28fd5ceea3dc05557535adc9e7febc9a415 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 14 Feb 2025 02:32:52 -0800 Subject: [PATCH 04/32] WIP: Prints the trigger args but not the trigger. Use template. --- copilot-visualizer.cabal | 7 +++ data/tikz.latex | 38 ++++++++++++++ src/Copilot/Visualize.hs | 108 +++++++++++++++++++++------------------ 3 files changed, 104 insertions(+), 49 deletions(-) create mode 100644 data/tikz.latex diff --git a/copilot-visualizer.cabal b/copilot-visualizer.cabal index 4647a1a..906b0c3 100644 --- a/copilot-visualizer.cabal +++ b/copilot-visualizer.cabal @@ -22,6 +22,7 @@ stability: Experimental category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG +data-files: data/tikz.latex x-curation: uncurated @@ -42,6 +43,8 @@ library build-depends: base >= 4.9 && < 5, aeson, + directory, + filepath, pretty >= 1.0 && < 1.2, ogma-extra >= 1.6.0 && < 1.7, @@ -51,3 +54,7 @@ library exposed-modules: Copilot.Visualize + + other-modules: + + Paths_copilot_visualizer diff --git a/data/tikz.latex b/data/tikz.latex new file mode 100644 index 0000000..dc2f9af --- /dev/null +++ b/data/tikz.latex @@ -0,0 +1,38 @@ +{{=<% %>=}} +\documentclass{standalone} +\usepackage{tikz} +\usepackage{tikz-timing} +\usepackage{xcolor} +\definecolor{F}{HTML}{ECD9ED} +\definecolor{T}{HTML}{D9ECED} +\begin{document} +\tikzset{ +every picture/.style={ + execute at end picture={ + \path (current bounding box.south west) +(-1,-1) (current bounding box.north east) +(1,1); + } +} +} + +\tikzset{ +timing/.style={x=5ex,y=2ex}, +timing/rowdist=4ex, +timing/dslope=0.1, +x=5ex, +timing/coldist=1ex, +timing/name/.style={font=\sffamily\scriptsize}, +timing/d/text/.style={font=\sffamily\tiny}, +} +\begin{tikztimingtable} +<%#adTraceElems%> +<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#tvIsBoolean%>[fill=<%tvValue%>]<%/tvIsBoolean%>D{<%tvValue%>}<%/tvIsEmpty%><%/teValues%>\\ +<%/adTraceElems%> + + printObserverOutputs + printTriggerOutputs +\extracode +\begin{background}[shift={(0.05,0)},help lines] +\vertlines[help lines,opacity=0.3]{-0.3ex,...,<%adLastSample%>} +\end{background} +\end{tikztimingtable} +\end{document} diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index d20f610..7aa9c98 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -5,41 +5,67 @@ module Copilot.Visualize where -import Data.Aeson -import Data.Maybe (isNothing, isJust, fromMaybe) -import Data.List import Copilot.Core import Copilot.Interpret.Eval +import Data.Aeson +import Data.List +import Data.Maybe ( fromMaybe, isJust, isNothing ) import GHC.Generics +import Paths_copilot_visualizer +import System.Directory +import System.Directory.Extra +import System.FilePath import Text.Printf import Text.Read +import Debug.Trace + +data AppData = AppData + { adTraceElems :: Trace + , adLastSample :: Int + } + deriving (Generic, Show) + +instance ToJSON AppData data TraceElem = TraceElem - { teName :: String - , teIsBoolean :: Bool - , teIsFloat :: Bool - , teValues :: [ String ] - } + { teName :: String + , teValues :: [ TraceValue ] + } deriving (Generic, Show) instance ToJSON TraceElem +data TraceValue = TraceValue + { tvValue :: String + , tvIsBoolean :: Bool + , tvIsFloat :: Bool + , tvIsEmpty :: Bool + } + deriving (Generic, Show) + +instance ToJSON TraceValue + type Trace = [ TraceElem ] makeTrace :: Int -- ^ Number of steps to interpret. -> Spec -- ^ Specification to interpret. -> IO () -makeTrace k spec = - print $ toJSON $ makeTraceEval k spec e +makeTrace k spec = do + dir <- getDataDir + let f = dir "data" + let subs = toJSON $ makeTraceEval k spec e + print subs + print f + copyTemplate f subs "target" where e = eval Haskell k spec makeTraceEval :: Int -> Spec -> ExecTrace - -> Trace + -> AppData makeTraceEval k spec e = - observerTEs ++ triggerTEs + AppData (observerTEs ++ triggerTEs) (k - 1) where observerTEs = map observerTE obsvs @@ -47,38 +73,38 @@ makeTraceEval k spec e = observerTE :: (String, [Output]) -> TraceElem observerTE (name, outputs) = TraceElem - { teName = name - , teIsBoolean = boolean - , teIsFloat = float - , teValues = outputs + { teName = name + , teValues = map teVal outputs } where - boolean = case outputs of - [] -> False - (x:_) -> isBoolean x + teVal x = TraceValue (showValue x) (isBoolean x) (isFloat x) (x == "--") + + showValue s | isBoolean s = showValueBoolean s + | isFloat s = showValueFloat s + | otherwise = s - float = case outputs of - [] -> False - (x:_) -> isFloat x + showValueBoolean :: String -> String + showValueBoolean "true" = "T" + showValueBoolean "false" = "F" + + showValueFloat :: String -> String + showValueFloat "--" = "--" + showValueFloat s = trace s $ (formatFloat . read) s + where + formatFloat :: Double -> String + formatFloat = printf "%.2g" triggerTE :: (String, [[String]]) -> [TraceElem] triggerTE (name, ls) = map triggerArgTE (zip ls [0..]) where triggerArgTE (values, i) = - TraceElem { teName = name ++ " # " ++ show i - , teIsBoolean = boolean - , teIsFloat = float - , teValues = values + TraceElem { teName = name ++ " arg " ++ show i + , teValues = values' } where - boolean = case values of - [] -> False - (x:_) -> isBoolean x - - float = case values of - [] -> False - (x:_) -> isFloat x + values' = map teVal values + teVal x = TraceValue (showValue x) (isBoolean x) (isFloat x) (x == "--") trigs :: [(String, [[String]])] trigs = map (printOutputs . regroup) trigs' @@ -107,22 +133,6 @@ makeTraceEval k spec e = Nothing -> error "Couldn't find given trigger in spec, should never occur!" Just t -> length $ triggerArgs t --- printTriggerOutput :: (String, [Maybe [Output]], Int) -> TraceElem --- printTriggerOutput (name, ls, argsLength) = --- signal name trig --- <> --- "\n" --- <> --- concatMap (\(v, n) -> signal n (showValues v)) (zip (args argsLength) argNames) --- where --- trig :: [String] --- trig = concatMap printTriggerOutputListElem ls --- --- args :: Int -> [[Maybe Output]] --- args argsLength = transpose $ transMaybes ls argsLength --- --- argNames = [name <> " arg \\#" <> show n | n <- [0..]] - -- Push Maybe's to inner level. transMaybes :: [Maybe [Output]] -> Int -> [[Maybe Output]] transMaybes [] _ = [] From c06b57ca15b06412a31434f55d65cedf5d66e50a Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 14 Feb 2025 02:37:12 -0800 Subject: [PATCH 05/32] Remove old code from template --- data/tikz.latex | 3 --- 1 file changed, 3 deletions(-) diff --git a/data/tikz.latex b/data/tikz.latex index dc2f9af..c8a7752 100644 --- a/data/tikz.latex +++ b/data/tikz.latex @@ -27,9 +27,6 @@ timing/d/text/.style={font=\sffamily\tiny}, <%#adTraceElems%> <%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#tvIsBoolean%>[fill=<%tvValue%>]<%/tvIsBoolean%>D{<%tvValue%>}<%/tvIsEmpty%><%/teValues%>\\ <%/adTraceElems%> - - printObserverOutputs - printTriggerOutputs \extracode \begin{background}[shift={(0.05,0)},help lines] \vertlines[help lines,opacity=0.3]{-0.3ex,...,<%adLastSample%>} From f05f47743a3c4ee2f8f2d0c9b6ae54798bec14a1 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 09:39:25 -0800 Subject: [PATCH 06/32] Comment out debug message. --- src/Copilot/Visualize.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 7aa9c98..3fa88d3 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -54,8 +54,8 @@ makeTrace k spec = do dir <- getDataDir let f = dir "data" let subs = toJSON $ makeTraceEval k spec e - print subs - print f + -- print subs + -- print f copyTemplate f subs "target" where e = eval Haskell k spec From 830f6b923cad2f3f8530d72ce48065a335ff0d94 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 09:43:37 -0800 Subject: [PATCH 07/32] Fix detection of floats. --- src/Copilot/Visualize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 3fa88d3..6d3054e 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -274,7 +274,7 @@ isBoolean "false" = True isBoolean _ = False isFloat s = - isJust asInt || isNothing asFloat + isJust asInt || isJust asFloat where asInt :: Maybe Int asInt = readMaybe s From 2ccbefdff112363f13d6d5a88b21eead72722db7 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 12:26:58 -0800 Subject: [PATCH 08/32] Add visualization to HTML. --- copilot-visualizer.cabal | 1 + data/tikz.latex | 4 +- data/timeline.html | 232 +++++++++++++++++++++++++++++++++++++++ src/Copilot/Visualize.hs | 21 ++-- 4 files changed, 249 insertions(+), 9 deletions(-) create mode 100644 data/timeline.html diff --git a/copilot-visualizer.cabal b/copilot-visualizer.cabal index 906b0c3..e19197b 100644 --- a/copilot-visualizer.cabal +++ b/copilot-visualizer.cabal @@ -23,6 +23,7 @@ category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG data-files: data/tikz.latex + data/timeline.html x-curation: uncurated diff --git a/data/tikz.latex b/data/tikz.latex index c8a7752..5a26b14 100644 --- a/data/tikz.latex +++ b/data/tikz.latex @@ -3,8 +3,8 @@ \usepackage{tikz} \usepackage{tikz-timing} \usepackage{xcolor} -\definecolor{F}{HTML}{ECD9ED} -\definecolor{T}{HTML}{D9ECED} +\definecolor{false}{HTML}{ECD9ED} +\definecolor{true}{HTML}{D9ECED} \begin{document} \tikzset{ every picture/.style={ diff --git a/data/timeline.html b/data/timeline.html new file mode 100644 index 0000000..52ba290 --- /dev/null +++ b/data/timeline.html @@ -0,0 +1,232 @@ + + + + + + Copilot Visualizer + + + + + + + + +
+ +
+ + + + diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 6d3054e..7cff3b1 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -27,8 +27,12 @@ data AppData = AppData instance ToJSON AppData +type Trace = [ TraceElem ] + data TraceElem = TraceElem { teName :: String + , teIsBoolean :: Bool + , teIsFloat :: Bool , teValues :: [ TraceValue ] } deriving (Generic, Show) @@ -36,7 +40,7 @@ data TraceElem = TraceElem instance ToJSON TraceElem data TraceValue = TraceValue - { tvValue :: String + { tvValue :: String , tvIsBoolean :: Bool , tvIsFloat :: Bool , tvIsEmpty :: Bool @@ -45,8 +49,6 @@ data TraceValue = TraceValue instance ToJSON TraceValue -type Trace = [ TraceElem ] - makeTrace :: Int -- ^ Number of steps to interpret. -> Spec -- ^ Specification to interpret. -> IO () @@ -74,9 +76,12 @@ makeTraceEval k spec e = observerTE :: (String, [Output]) -> TraceElem observerTE (name, outputs) = TraceElem { teName = name - , teValues = map teVal outputs + , teValues = values + , teIsBoolean = any tvIsBoolean values + , teIsFloat = any tvIsFloat values } where + values = map teVal outputs teVal x = TraceValue (showValue x) (isBoolean x) (isFloat x) (x == "--") showValue s | isBoolean s = showValueBoolean s @@ -84,8 +89,8 @@ makeTraceEval k spec e = | otherwise = s showValueBoolean :: String -> String - showValueBoolean "true" = "T" - showValueBoolean "false" = "F" + showValueBoolean "true" = "true" + showValueBoolean "false" = "false" showValueFloat :: String -> String showValueFloat "--" = "--" @@ -99,7 +104,9 @@ makeTraceEval k spec e = map triggerArgTE (zip ls [0..]) where triggerArgTE (values, i) = - TraceElem { teName = name ++ " arg " ++ show i + TraceElem { teName = name ++ "Arg" ++ show i + , teIsBoolean = any tvIsBoolean values' + , teIsFloat = any tvIsFloat values' , teValues = values' } where From 3d92f8d8786ea06e8d59a3155dc9ef7be807ef41 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 12:52:24 -0800 Subject: [PATCH 09/32] Use T and F instead of true and false in latex --- data/tikz.latex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/data/tikz.latex b/data/tikz.latex index 5a26b14..66c9171 100644 --- a/data/tikz.latex +++ b/data/tikz.latex @@ -6,6 +6,8 @@ \definecolor{false}{HTML}{ECD9ED} \definecolor{true}{HTML}{D9ECED} \begin{document} +\newcommand{\true}{T} +\newcommand{\false}{F} \tikzset{ every picture/.style={ execute at end picture={ @@ -25,7 +27,7 @@ timing/d/text/.style={font=\sffamily\tiny}, } \begin{tikztimingtable} <%#adTraceElems%> -<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#tvIsBoolean%>[fill=<%tvValue%>]<%/tvIsBoolean%>D{<%tvValue%>}<%/tvIsEmpty%><%/teValues%>\\ +<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#tvIsBoolean%>[fill=<%tvValue%>]D{\<%tvValue%>}<%/tvIsBoolean%><%^tvIsBoolean%>D{<%tvValue%>}<%/tvIsBoolean%><%/tvIsEmpty%><%/teValues%>\\ <%/adTraceElems%> \extracode \begin{background}[shift={(0.05,0)},help lines] From 05db5372a7bb4717d82061bb8f5cc18d195504bf Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 12:59:40 -0800 Subject: [PATCH 10/32] Remove debugging --- src/Copilot/Visualize.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 7cff3b1..700f4c3 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -17,7 +17,6 @@ import System.Directory.Extra import System.FilePath import Text.Printf import Text.Read -import Debug.Trace data AppData = AppData { adTraceElems :: Trace @@ -94,7 +93,7 @@ makeTraceEval k spec e = showValueFloat :: String -> String showValueFloat "--" = "--" - showValueFloat s = trace s $ (formatFloat . read) s + showValueFloat s = formatFloat $ read s where formatFloat :: Double -> String formatFloat = printf "%.2g" From e502615c41d476bfd386a2299bf60077d644b9ae Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 13:14:22 -0800 Subject: [PATCH 11/32] Restore trigger names --- src/Copilot/Visualize.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 700f4c3..5c1a069 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -17,6 +17,7 @@ import System.Directory.Extra import System.FilePath import Text.Printf import Text.Read +import Debug.Trace data AppData = AppData { adTraceElems :: Trace @@ -100,10 +101,10 @@ makeTraceEval k spec e = triggerTE :: (String, [[String]]) -> [TraceElem] triggerTE (name, ls) = - map triggerArgTE (zip ls [0..]) + map triggerArgTE (zip ls ("" : map (\x -> "Arg" ++ show x) [0..])) where triggerArgTE (values, i) = - TraceElem { teName = name ++ "Arg" ++ show i + TraceElem { teName = name ++ i , teIsBoolean = any tvIsBoolean values' , teIsFloat = any tvIsFloat values' , teValues = values' @@ -125,9 +126,9 @@ makeTraceEval k spec e = regroup :: (String, [Maybe [Output]], Int) -> (String, [[Maybe Output]]) regroup (n, ls, len) = (n, map rep ls) where - rep :: Maybe [a] -> [Maybe a] - rep Nothing = replicate len Nothing - rep (Just x) = map Just x + rep :: Maybe [Output] -> [Maybe Output] + rep Nothing = Just "false" : replicate len Nothing + rep (Just x) = Just "true" : map Just x trigs' :: [(String, [Maybe [Output]], Int)] trigs' = map addArgsLength (interpTriggers e) From e4df254a0f8ba70f62400bfe9606c9924c7d2def Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 14:03:09 -0800 Subject: [PATCH 12/32] Cleaning --- src/Copilot/Visualize.hs | 279 +++++++++++---------------------------- 1 file changed, 75 insertions(+), 204 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 5c1a069..8c2855d 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -56,8 +56,6 @@ makeTrace k spec = do dir <- getDataDir let f = dir "data" let subs = toJSON $ makeTraceEval k spec e - -- print subs - -- print f copyTemplate f subs "target" where e = eval Haskell k spec @@ -69,217 +67,65 @@ makeTraceEval :: Int makeTraceEval k spec e = AppData (observerTEs ++ triggerTEs) (k - 1) where - observerTEs = map observerTE obsvs - - triggerTEs = concatMap triggerTE trigs - - observerTE :: (String, [Output]) -> TraceElem - observerTE (name, outputs) = TraceElem - { teName = name - , teValues = values - , teIsBoolean = any tvIsBoolean values - , teIsFloat = any tvIsFloat values - } - where - values = map teVal outputs - teVal x = TraceValue (showValue x) (isBoolean x) (isFloat x) (x == "--") - - showValue s | isBoolean s = showValueBoolean s - | isFloat s = showValueFloat s - | otherwise = s - - showValueBoolean :: String -> String - showValueBoolean "true" = "true" - showValueBoolean "false" = "false" - - showValueFloat :: String -> String - showValueFloat "--" = "--" - showValueFloat s = formatFloat $ read s - where - formatFloat :: Double -> String - formatFloat = printf "%.2g" - - triggerTE :: (String, [[String]]) -> [TraceElem] - triggerTE (name, ls) = - map triggerArgTE (zip ls ("" : map (\x -> "Arg" ++ show x) [0..])) - where - triggerArgTE (values, i) = - TraceElem { teName = name ++ i - , teIsBoolean = any tvIsBoolean values' - , teIsFloat = any tvIsFloat values' - , teValues = values' - } - where - values' = map teVal values - teVal x = TraceValue (showValue x) (isBoolean x) (isFloat x) (x == "--") - - trigs :: [(String, [[String]])] - trigs = map (printOutputs . regroup) trigs' - where - printOutputs :: (String, [[Maybe Output]]) -> (String, [[String]]) - printOutputs (nm, ls) = (nm, transpose $ map (map ppTriggerOutput) ls) - - ppTriggerOutput :: Maybe Output -> String - ppTriggerOutput Nothing = "--" - ppTriggerOutput (Just v) = v - - regroup :: (String, [Maybe [Output]], Int) -> (String, [[Maybe Output]]) - regroup (n, ls, len) = (n, map rep ls) - where - rep :: Maybe [Output] -> [Maybe Output] - rep Nothing = Just "false" : replicate len Nothing - rep (Just x) = Just "true" : map Just x - - trigs' :: [(String, [Maybe [Output]], Int)] - trigs' = map addArgsLength (interpTriggers e) - where - addArgsLength :: (String, [Maybe [Output]]) -> (String, [Maybe [Output]], Int) - addArgsLength (name, output) = (name, output, argsLength) - where - argsLength = case find (\t -> triggerName t == name) (specTriggers spec) of - Nothing -> error "Couldn't find given trigger in spec, should never occur!" - Just t -> length $ triggerArgs t - - -- Push Maybe's to inner level. - transMaybes :: [Maybe [Output]] -> Int -> [[Maybe Output]] - transMaybes [] _ = [] - transMaybes (xs:xss) argsLength = case xs of - Just xs' -> map Just xs' : transMaybes xss argsLength - Nothing -> replicate argsLength Nothing : transMaybes xss argsLength - - obsvs :: [(String, [Output])] - obsvs = interpObservers e - -paint :: Int -- ^ Number of steps to interpret. - -> Spec -- ^ Specification to interpret. - -> IO () -paint k spec = - paintEvaluation k spec e - where - e = eval Haskell k spec - -paintEvaluation :: Int - -> Spec - -> ExecTrace - -> IO () -paintEvaluation k spec e = do - putStrLn "\\documentclass{standalone}" - putStrLn "\\usepackage{tikz}" - putStrLn "\\usepackage{tikz-timing}" - putStrLn "\\usepackage{xcolor}" - putStrLn "\\definecolor{false}{HTML}{ECD9ED}" - putStrLn "\\definecolor{true}{HTML}{D9ECED}" - putStrLn "\\begin{document}" - putStrLn "\\tikzset{" - putStrLn "every picture/.style={" - putStrLn " execute at end picture={" - putStrLn " \\path (current bounding box.south west) +(-1,-1) (current bounding box.north east) +(1,1);" - putStrLn " }" - putStrLn "}" - putStrLn "}" - putStrLn "" - putStrLn "\\tikzset{" - putStrLn "timing/.style={x=5ex,y=2ex}," - putStrLn "timing/rowdist=4ex," - putStrLn "timing/dslope=0.1," - putStrLn "x=5ex," - putStrLn "timing/coldist=1ex," - putStrLn "timing/name/.style={font=\\sffamily\\scriptsize}," - putStrLn "timing/d/text/.style={font=\\sffamily\\tiny}," - putStrLn "}" - putStrLn "\\begin{tikztimingtable}" - printObserverOutputs - printTriggerOutputs - putStrLn "\\extracode" - putStrLn "\\begin{background}[shift={(0.05,0)},help lines]" - putStrLn $ "\\vertlines[help lines,opacity=0.3]{-0.3ex,...," - ++ show (k - 1) - ++ "}" - putStrLn "\\end{background}" - putStrLn "\\end{tikztimingtable}" - putStrLn "\\end{document}" + observerTEs = map mkTraceElem (interpObservers e) + triggerTEs = map mkTraceElem (interpTriggersWithArgs spec e) + +-- Compute the list of values associated to a trigger and its arguments, which +-- the first values being the ones for the trigger itself, and subsequent +-- values being those of the arguments to the trigger. +interpTriggersWithArgs :: Spec -> ExecTrace -> [(String, [Output])] +interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) where - signal :: String -> [String] -> String - signal name values = name <> " & g" <> concat values <> "\\\\" - - printTriggerOutputs :: IO () - printTriggerOutputs = mapM_ putStrLn (map printTriggerOutput trigs) - where - printTriggerOutput :: (String, [Maybe [Output]], Int) -> String - printTriggerOutput (name, ls, argsLength) = - signal name trig - <> - "\n" - <> - concatMap (\(v, n) -> signal n (showValues v)) (zip (args argsLength) argNames) - where - trig :: [String] - trig = concatMap printTriggerOutputListElem ls - - args :: Int -> [[Maybe Output]] - args argsLength = transpose $ transMaybes ls argsLength - - argNames = [name <> " arg \\#" <> show n | n <- [0..]] - - -- Push Maybe's to inner level. - transMaybes :: [Maybe [Output]] -> Int -> [[Maybe Output]] - transMaybes [] _ = [] - transMaybes (xs:xss) argsLength = case xs of - Just xs' -> map Just xs' : transMaybes xss argsLength - Nothing -> replicate argsLength Nothing : transMaybes xss argsLength - - -- Ignores the value, just interprets as a boolean - printTriggerOutputListElem :: Maybe [Output] -> [String] - printTriggerOutputListElem Nothing = ["[fill=false]D{F}"] - printTriggerOutputListElem (Just _) = ["[fill=true]D{T}"] - - --------------------------------------------------------------------------- - printObserverOutputs :: IO () - printObserverOutputs = mapM_ putStrLn (map observerOutput obsvs) - where - observerOutput (name, ls) = signal name (showValues $ map Just ls) - - --------------------------------------------------------------------------- - showValues :: [Maybe String] -> [String] - showValues = map showValue - - showValue :: Maybe String -> String - showValue Nothing = "S" - showValue (Just s) | isBoolean s = showValueBoolean s - | isFloat s = showValueFloat s - | otherwise = showValueNumber s - - showValueBoolean :: String -> String - showValueBoolean "true" = "[fill=true]D{T}" - showValueBoolean "false" = "[fill=false]D{F}" - - showValueFloat :: String -> String - showValueFloat = formatFloat . read + -- This function adds one more output for the trigger itself. + triggerOutputs :: (String, [Maybe [Output]]) -> [(String, [Output])] + triggerOutputs (n, ls) = zip names ls' where - formatFloat :: Double -> String - formatFloat = printf "D{%.2g}" - - showValueNumber :: String -> String - showValueNumber n = "D{" <> n <> "}" - --------------------------------------------------------------------------- + -- Put the name of the trigger first, then add a name for each + -- argument. + names = n : map (\x -> n ++ "Arg" ++ show x) [0..] + + ls' = transpose $ map rep ls + + rep :: Maybe [Output] -> [Output] + rep Nothing = "false" : replicate len "--" + rep (Just x) = "true" : x + + len = numArgs spec n + +-- Number of arguments to a trigger in a spec. +-- +-- PRE: name exists as a trigger in spec. +numArgs :: Spec -> String -> Int +numArgs spec name = + case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t + +mkTraceElem :: (String, [Output]) -> TraceElem +mkTraceElem (name, outputs) = TraceElem + { teName = name + , teValues = values + , teIsBoolean = any tvIsBoolean values + , teIsFloat = any tvIsFloat values + } + where + values = map mkTraceValue outputs - trigs :: [(String, [Maybe [Output]], Int)] - trigs = map addArgsLength (interpTriggers e) - where - addArgsLength :: (String, [Maybe [Output]]) -> (String, [Maybe [Output]], Int) - addArgsLength (name, output) = (name, output, argsLength) - where - argsLength = case find (\t -> triggerName t == name) (specTriggers spec) of - Nothing -> error "Couldn't find given trigger in spec, should never occur!" - Just t -> length $ triggerArgs t +mkTraceValue :: String -> TraceValue +mkTraceValue x = TraceValue (showValue x) (isBoolean x) (isFloat x) (isEmpty x) - obsvs :: [(String, [Output])] - obsvs = interpObservers e +isEmpty :: String -> Bool +isEmpty "--" = True +isEmpty _ = False +-- | True if the input value denotes a boolean value. +isBoolean :: String -> Bool isBoolean "true" = True isBoolean "false" = True isBoolean _ = False +-- | True if the input value denotes a floating point value. +isFloat :: String -> Bool isFloat s = isJust asInt || isJust asFloat where @@ -288,3 +134,28 @@ isFloat s = asFloat :: Maybe Float asFloat = readMaybe s + +-- | Show an output, if it exists. +showOutputM :: Maybe Output -> String +showOutputM Nothing = "--" +showOutputM (Just v) = showValue v + +-- | Show a value. +showValue :: String -> String +showValue s | isFloat s = showValueFloat s + | otherwise = s + +showValueFloat :: String -> String +showValueFloat "--" = "--" +showValueFloat s = formatFloat $ read s + where + formatFloat :: Double -> String + formatFloat = printf "%.2g" + +-- | Given a list of maybe lists of known length, this function creates a list +-- of lists, pushing the Maybe's inside. +transMaybes :: [Maybe [a]] -> Int -> [[Maybe a]] +transMaybes [] _ = [] +transMaybes (xs:xss) argsLength = case xs of + Just xs' -> map Just xs' : transMaybes xss argsLength + Nothing -> replicate argsLength Nothing : transMaybes xss argsLength From 3e157d956a2589a55a0cf7b1133d7eaa7f28086a Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 14:11:06 -0800 Subject: [PATCH 13/32] Cleaning --- src/Copilot/Visualize.hs | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 8c2855d..70e5dfb 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -84,11 +84,17 @@ interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) -- argument. names = n : map (\x -> n ++ "Arg" ++ show x) [0..] - ls' = transpose $ map rep ls + -- Put the values of the trigger first, then add the values for each + -- argument. + ls' = map triggerValue ls : transpose (map rep ls) + + triggerValue :: Maybe [Output] -> Output + triggerValue Nothing = "false" + triggerValue (Just _) = "true" rep :: Maybe [Output] -> [Output] - rep Nothing = "false" : replicate len "--" - rep (Just x) = "true" : x + rep Nothing = replicate len "" + rep (Just x) = x len = numArgs spec n @@ -115,19 +121,19 @@ mkTraceValue :: String -> TraceValue mkTraceValue x = TraceValue (showValue x) (isBoolean x) (isFloat x) (isEmpty x) isEmpty :: String -> Bool -isEmpty "--" = True -isEmpty _ = False +isEmpty "" = True +isEmpty _ = False -- | True if the input value denotes a boolean value. isBoolean :: String -> Bool -isBoolean "true" = True +isBoolean "true" = True isBoolean "false" = True -isBoolean _ = False +isBoolean _ = False -- | True if the input value denotes a floating point value. isFloat :: String -> Bool isFloat s = - isJust asInt || isJust asFloat + isJust asInt || isJust asFloat where asInt :: Maybe Int asInt = readMaybe s @@ -142,7 +148,8 @@ showOutputM (Just v) = showValue v -- | Show a value. showValue :: String -> String -showValue s | isFloat s = showValueFloat s +showValue s | isEmpty s = "--" + | isFloat s = showValueFloat s | otherwise = s showValueFloat :: String -> String From 5817a3c95fb5ffdb146665b55da929b753ece5dc Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 14:13:21 -0800 Subject: [PATCH 14/32] Cleaning --- src/Copilot/Visualize.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 70e5dfb..9c3394e 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -82,19 +82,19 @@ interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) where -- Put the name of the trigger first, then add a name for each -- argument. - names = n : map (\x -> n ++ "Arg" ++ show x) [0..] + names = n : map (\ix -> n ++ "Arg" ++ show ix) [0..] -- Put the values of the trigger first, then add the values for each -- argument. - ls' = map triggerValue ls : transpose (map rep ls) + ls' = map triggerValue ls : transpose (map argValues ls) triggerValue :: Maybe [Output] -> Output triggerValue Nothing = "false" triggerValue (Just _) = "true" - rep :: Maybe [Output] -> [Output] - rep Nothing = replicate len "" - rep (Just x) = x + argValues :: Maybe [Output] -> [Output] + argValues Nothing = replicate len "" + argValues (Just x) = x len = numArgs spec n From a151fe20bb33f88d91d9354afb1ee62316c0143c Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 14:58:18 -0800 Subject: [PATCH 15/32] Remove duplicated isBoolean/isFloat --- data/tikz.latex | 2 +- data/timeline.html | 2 +- src/Copilot/Visualize.hs | 8 +++----- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/data/tikz.latex b/data/tikz.latex index 66c9171..b05f2c1 100644 --- a/data/tikz.latex +++ b/data/tikz.latex @@ -27,7 +27,7 @@ timing/d/text/.style={font=\sffamily\tiny}, } \begin{tikztimingtable} <%#adTraceElems%> -<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#tvIsBoolean%>[fill=<%tvValue%>]D{\<%tvValue%>}<%/tvIsBoolean%><%^tvIsBoolean%>D{<%tvValue%>}<%/tvIsBoolean%><%/tvIsEmpty%><%/teValues%>\\ +<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#teIsBoolean%>[fill=<%tvValue%>]D{\<%tvValue%>}<%/teIsBoolean%><%^teIsBoolean%>D{<%tvValue%>}<%/teIsBoolean%><%/tvIsEmpty%><%/teValues%>\\ <%/adTraceElems%> \extracode \begin{background}[shift={(0.05,0)},help lines] diff --git a/data/timeline.html b/data/timeline.html index 52ba290..f576d88 100644 --- a/data/timeline.html +++ b/data/timeline.html @@ -74,7 +74,7 @@ {{#adTraceElems}} {{teName}}: [ {{#teValues}} -{time: {{teName}}_ix++, value: {{#tvIsBoolean}}{{tvValue}}{{/tvIsBoolean}}{{#tvIsFloat}}{{tvValue}}{{/tvIsFloat}}{{^tvIsBoolean}}{{^tvIsFloat}}"{{tvValue}}"{{/tvIsFloat}}{{/tvIsBoolean}}, duration: 1}, +{time: {{teName}}_ix++, value: {{#teIsBoolean}}{{tvValue}}{{/teIsBoolean}}{{#teIsFloat}}{{tvValue}}{{/teIsFloat}}{{^teIsBoolean}}{{^teIsFloat}}"{{tvValue}}"{{/teIsFloat}}{{/teIsBoolean}}, duration: 1}, {{/teValues}} ], {{/adTraceElems}} diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 9c3394e..52f7234 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -41,8 +41,6 @@ instance ToJSON TraceElem data TraceValue = TraceValue { tvValue :: String - , tvIsBoolean :: Bool - , tvIsFloat :: Bool , tvIsEmpty :: Bool } deriving (Generic, Show) @@ -111,14 +109,14 @@ mkTraceElem :: (String, [Output]) -> TraceElem mkTraceElem (name, outputs) = TraceElem { teName = name , teValues = values - , teIsBoolean = any tvIsBoolean values - , teIsFloat = any tvIsFloat values + , teIsBoolean = any (isBoolean . tvValue) values + , teIsFloat = any (isFloat . tvValue) values } where values = map mkTraceValue outputs mkTraceValue :: String -> TraceValue -mkTraceValue x = TraceValue (showValue x) (isBoolean x) (isFloat x) (isEmpty x) +mkTraceValue x = TraceValue (showValue x) (isEmpty x) isEmpty :: String -> Bool isEmpty "" = True From ee3d7ee7c4c1ef1bf871b1940423f6454fc4bad0 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 14:58:28 -0800 Subject: [PATCH 16/32] Cleaning --- src/Copilot/Visualize.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 52f7234..9dcf94d 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -17,7 +17,6 @@ import System.Directory.Extra import System.FilePath import Text.Printf import Text.Read -import Debug.Trace data AppData = AppData { adTraceElems :: Trace From bf8e76c36cb31a0994dd2b8891ba94e509206867 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 15:16:20 -0800 Subject: [PATCH 17/32] Cleaning --- src/Copilot/Visualize.hs | 85 +++++++++++++++++----------------------- 1 file changed, 37 insertions(+), 48 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index 9dcf94d..e4252a2 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -64,47 +64,35 @@ makeTraceEval :: Int makeTraceEval k spec e = AppData (observerTEs ++ triggerTEs) (k - 1) where - observerTEs = map mkTraceElem (interpObservers e) + observerTEs = map mkTraceElem (interpObserversOpt spec e) triggerTEs = map mkTraceElem (interpTriggersWithArgs spec e) +interpObserversOpt :: Spec -> ExecTrace -> [(String, [Maybe Output])] +interpObserversOpt spec e = + map (\(n, os) -> (n, map Just os)) (interpObservers e) + -- Compute the list of values associated to a trigger and its arguments, which -- the first values being the ones for the trigger itself, and subsequent -- values being those of the arguments to the trigger. -interpTriggersWithArgs :: Spec -> ExecTrace -> [(String, [Output])] +interpTriggersWithArgs :: Spec -> ExecTrace -> [(String, [Maybe Output])] interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) where -- This function adds one more output for the trigger itself. - triggerOutputs :: (String, [Maybe [Output]]) -> [(String, [Output])] - triggerOutputs (n, ls) = zip names ls' + triggerOutputs :: (String, [Maybe [Output]]) -> [(String, [Maybe Output])] + triggerOutputs (triggerName, triggerArgs) = + (triggerName, triggerValues) : zip argNames argValues where - -- Put the name of the trigger first, then add a name for each - -- argument. - names = n : map (\ix -> n ++ "Arg" ++ show ix) [0..] - - -- Put the values of the trigger first, then add the values for each - -- argument. - ls' = map triggerValue ls : transpose (map argValues ls) - - triggerValue :: Maybe [Output] -> Output - triggerValue Nothing = "false" - triggerValue (Just _) = "true" + triggerValues = map triggerValue triggerArgs - argValues :: Maybe [Output] -> [Output] - argValues Nothing = replicate len "" - argValues (Just x) = x + triggerValue :: Maybe a -> Maybe Output + triggerValue Nothing = Just "false" + triggerValue (Just _) = Just "true" - len = numArgs spec n + argNames = map (\ix -> triggerName ++ "Arg" ++ show ix) [0..] + argValues = transpose (transMaybes triggerArgs numArgs) + numArgs = triggerNumArgs spec triggerName --- Number of arguments to a trigger in a spec. --- --- PRE: name exists as a trigger in spec. -numArgs :: Spec -> String -> Int -numArgs spec name = - case find (\t -> triggerName t == name) (specTriggers spec) of - Nothing -> error "Couldn't find given trigger in spec, should never occur!" - Just t -> length $ triggerArgs t - -mkTraceElem :: (String, [Output]) -> TraceElem +mkTraceElem :: (String, [Maybe Output]) -> TraceElem mkTraceElem (name, outputs) = TraceElem { teName = name , teValues = values @@ -114,12 +102,8 @@ mkTraceElem (name, outputs) = TraceElem where values = map mkTraceValue outputs -mkTraceValue :: String -> TraceValue -mkTraceValue x = TraceValue (showValue x) (isEmpty x) - -isEmpty :: String -> Bool -isEmpty "" = True -isEmpty _ = False +mkTraceValue :: Maybe Output -> TraceValue +mkTraceValue x = TraceValue (showValue x) (isNothing x) -- | True if the input value denotes a boolean value. isBoolean :: String -> Bool @@ -138,24 +122,29 @@ isFloat s = asFloat :: Maybe Float asFloat = readMaybe s --- | Show an output, if it exists. -showOutputM :: Maybe Output -> String -showOutputM Nothing = "--" -showOutputM (Just v) = showValue v - -- | Show a value. -showValue :: String -> String -showValue s | isEmpty s = "--" - | isFloat s = showValueFloat s - | otherwise = s - -showValueFloat :: String -> String -showValueFloat "--" = "--" -showValueFloat s = formatFloat $ read s +showValue :: Maybe Output -> String +showValue Nothing = "--" +showValue (Just s) | isFloat s = showValueFloat s + | otherwise = s + +showValueFloat :: Output -> String +showValueFloat = formatFloat . read where formatFloat :: Double -> String formatFloat = printf "%.2g" +-- * Auxiliary functions + +-- Number of arguments to a trigger in a spec. +-- +-- PRE: name exists as a trigger in spec. +triggerNumArgs :: Spec -> String -> Int +triggerNumArgs spec name = + case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t + -- | Given a list of maybe lists of known length, this function creates a list -- of lists, pushing the Maybe's inside. transMaybes :: [Maybe [a]] -> Int -> [[Maybe a]] From 0fcb73ccea950032896418a8fdce7fdf7efaf40e Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 18:11:39 -0800 Subject: [PATCH 18/32] Cleaning --- src/Copilot/Visualize.hs | 136 ++++++++++++++++++++++----------------- 1 file changed, 76 insertions(+), 60 deletions(-) diff --git a/src/Copilot/Visualize.hs b/src/Copilot/Visualize.hs index e4252a2..115e96f 100644 --- a/src/Copilot/Visualize.hs +++ b/src/Copilot/Visualize.hs @@ -5,19 +5,63 @@ module Copilot.Visualize where -import Copilot.Core -import Copilot.Interpret.Eval +-- External imports import Data.Aeson import Data.List -import Data.Maybe ( fromMaybe, isJust, isNothing ) +import Data.Maybe ( fromMaybe, isJust, isNothing ) import GHC.Generics -import Paths_copilot_visualizer import System.Directory import System.Directory.Extra import System.FilePath import Text.Printf import Text.Read +-- External imports: Copilot +import Copilot.Core +import Copilot.Interpret.Eval + +-- Internal imports +import Paths_copilot_visualizer + +-- | Generate a visualization of a specification for a given number of steps. +makeTrace :: Int -- ^ Number of steps to interpret. + -> Spec -- ^ Specification to interpret. + -> IO () +makeTrace k spec = do + dir <- getDataDir + let f = dir "data" + let subs = toJSON $ makeTraceEval k spec e + copyTemplate f subs "target" + where + e = eval Haskell k spec + +-- | Generate an abstract representation of a trace of a specification +-- interpreted for a given number of steps. +makeTraceEval :: Int + -> Spec + -> ExecTrace + -> AppData +makeTraceEval k spec e = + AppData (observerTEs ++ triggerTEs) (k - 1) + where + observerTEs = map mkTraceElem (interpObserversOpt spec e) + triggerTEs = map mkTraceElem (interpTriggersWithArgs spec e) + +mkTraceElem :: (String, [Maybe Output]) -> TraceElem +mkTraceElem (name, outputs) = TraceElem + { teName = name + , teValues = values + , teIsBoolean = any (isBoolean . tvValue) values + , teIsFloat = any (isFloat . tvValue) values + } + where + values = map mkTraceValue outputs + +mkTraceValue :: Maybe Output -> TraceValue +mkTraceValue x = TraceValue (showValue x) (isNothing x) + +-- * Abstract representation of a trace + data AppData = AppData { adTraceElems :: Trace , adLastSample :: Int @@ -39,41 +83,24 @@ data TraceElem = TraceElem instance ToJSON TraceElem data TraceValue = TraceValue - { tvValue :: String - , tvIsEmpty :: Bool + { tvValue :: String + , tvIsEmpty :: Bool } deriving (Generic, Show) instance ToJSON TraceValue -makeTrace :: Int -- ^ Number of steps to interpret. - -> Spec -- ^ Specification to interpret. - -> IO () -makeTrace k spec = do - dir <- getDataDir - let f = dir "data" - let subs = toJSON $ makeTraceEval k spec e - copyTemplate f subs "target" - where - e = eval Haskell k spec - -makeTraceEval :: Int - -> Spec - -> ExecTrace - -> AppData -makeTraceEval k spec e = - AppData (observerTEs ++ triggerTEs) (k - 1) - where - observerTEs = map mkTraceElem (interpObserversOpt spec e) - triggerTEs = map mkTraceElem (interpTriggersWithArgs spec e) +-- * Auxiliary functions +-- | Compute the list of values associated to observers. interpObserversOpt :: Spec -> ExecTrace -> [(String, [Maybe Output])] -interpObserversOpt spec e = +interpObserversOpt _spec e = map (\(n, os) -> (n, map Just os)) (interpObservers e) --- Compute the list of values associated to a trigger and its arguments, which --- the first values being the ones for the trigger itself, and subsequent --- values being those of the arguments to the trigger. +-- | Compute the list of values associated to triggers and their arguments. +-- +-- For each trigger, we first include the values of the trigger itself, and +-- then the values of the arguments to the trigger. interpTriggersWithArgs :: Spec -> ExecTrace -> [(String, [Maybe Output])] interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) where @@ -84,26 +111,25 @@ interpTriggersWithArgs spec e = concatMap triggerOutputs (interpTriggers e) where triggerValues = map triggerValue triggerArgs - triggerValue :: Maybe a -> Maybe Output + -- Value for the trigger at a given time, based on the values of its + -- arguments. + triggerValue :: Maybe [Output] -> Maybe Output triggerValue Nothing = Just "false" triggerValue (Just _) = Just "true" + -- Names and values for the arguments. argNames = map (\ix -> triggerName ++ "Arg" ++ show ix) [0..] - argValues = transpose (transMaybes triggerArgs numArgs) + argValues = transpose (transMaybes numArgs triggerArgs) numArgs = triggerNumArgs spec triggerName -mkTraceElem :: (String, [Maybe Output]) -> TraceElem -mkTraceElem (name, outputs) = TraceElem - { teName = name - , teValues = values - , teIsBoolean = any (isBoolean . tvValue) values - , teIsFloat = any (isFloat . tvValue) values - } - where - values = map mkTraceValue outputs - -mkTraceValue :: Maybe Output -> TraceValue -mkTraceValue x = TraceValue (showValue x) (isNothing x) +-- Number of arguments to a trigger in a spec. +-- +-- PRE: name exists as a trigger in spec. +triggerNumArgs :: Spec -> String -> Int +triggerNumArgs spec name = + case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t -- | True if the input value denotes a boolean value. isBoolean :: String -> Bool @@ -128,27 +154,17 @@ showValue Nothing = "--" showValue (Just s) | isFloat s = showValueFloat s | otherwise = s +-- | Show a floating point value. showValueFloat :: Output -> String showValueFloat = formatFloat . read where formatFloat :: Double -> String formatFloat = printf "%.2g" --- * Auxiliary functions - --- Number of arguments to a trigger in a spec. --- --- PRE: name exists as a trigger in spec. -triggerNumArgs :: Spec -> String -> Int -triggerNumArgs spec name = - case find (\t -> triggerName t == name) (specTriggers spec) of - Nothing -> error "Couldn't find given trigger in spec, should never occur!" - Just t -> length $ triggerArgs t - -- | Given a list of maybe lists of known length, this function creates a list -- of lists, pushing the Maybe's inside. -transMaybes :: [Maybe [a]] -> Int -> [[Maybe a]] -transMaybes [] _ = [] -transMaybes (xs:xss) argsLength = case xs of - Just xs' -> map Just xs' : transMaybes xss argsLength - Nothing -> replicate argsLength Nothing : transMaybes xss argsLength +transMaybes :: Int -> [Maybe [a]] -> [[Maybe a]] +transMaybes = map . transMaybes' + where + transMaybes' argsLength (Just xs) = map Just xs + transMaybes' argsLength Nothing = replicate argsLength Nothing From 1b6eecdcff5f8457753a73be5f11db37a1230613 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 17 Feb 2025 18:13:08 -0800 Subject: [PATCH 19/32] Remove unused css. --- data/timeline.html | 1 - 1 file changed, 1 deletion(-) diff --git a/data/timeline.html b/data/timeline.html index f576d88..1b25325 100644 --- a/data/timeline.html +++ b/data/timeline.html @@ -13,7 +13,6 @@ - + + +
+ +
+
+ + + + + + +
+ + + + + diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs new file mode 100644 index 0000000..ed9eb08 --- /dev/null +++ b/src/Copilot/Live.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Exception ( finally ) +import Control.Monad +import qualified Copilot.Core as Core +import Copilot.Interpret.Eval +import qualified Copilot.Visualize as View +import Data.Aeson +import qualified Data.Text as T +import Data.Typeable +import GHC.Generics +import Language.Copilot +import qualified Network.WebSockets as WS +import Prelude hiding ( div, not, (++), (<), (>) ) +import qualified Prelude + +main :: IO () +main = do + putStrLn "WebSocket server starting on port 9160..." + WS.runServer "127.0.0.1" 9160 (app spec) + +makeTraceEval' k spec' = + View.makeTraceEval k spec' (eval Haskell k spec') + +-- * App + +app :: Spec -> WS.ServerApp +app spec pending = do + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (return ()) $ do + spec' <- reify spec + + let k = 3 + + v <- newMVar (k, spec') + + let a = makeTraceEval' k spec' + samples = encode $ toJSON $ allSamples a + WS.sendTextData conn samples + + loop conn v + + where + + loop conn v = forever $ do + msg <- WS.receiveData conn + let (command, name) = + case T.unpack msg of + ('U':'p':' ':d:' ':s) -> (Up (read [d]), s) + ('D':'o':'w':'n':' ':d:' ':s) -> (Down (read [d]), s) + v -> (Noop, v) + + (k, spec') <- takeMVar v + let spec'' = case T.unpack msg of + "StepUp" -> spec' + "StepDown" -> spec' + _ -> apply spec' name command + + let k' = case T.unpack msg of + "StepUp" -> k + 1 + "StepDown" -> k - 1 + _ -> k + + putMVar v (k', spec'') + + let a = makeTraceEval' k' spec'' + samples = encode $ toJSON $ allSamples a + WS.sendTextData conn samples + +data Data = Data + { adLastSample :: Int + , adTraceElems :: [TraceElem] + } + deriving (Generic) + +instance ToJSON Data + +data TraceElem = TraceElem + { teName :: String + , teIsBoolean :: Bool + , teValues :: [Sample] + } + deriving (Generic) + +instance ToJSON TraceElem + +data Sample = Sample + { time :: Int, value :: String, duration :: Float } + deriving (Generic) + +instance ToJSON Sample + +allSamples :: View.AppData -> Data +allSamples appData = Data + { adLastSample = View.adLastSample appData + , adTraceElems = map toTraceElem (View.adTraceElems appData) + } + +toTraceElem :: View.TraceElem -> TraceElem +toTraceElem te = TraceElem + { teName = View.teName te + , teIsBoolean = View.teIsBoolean te + , teValues = map + (\(i, v) -> Sample i (View.tvValue v) 1) + (zip [0..] (View.teValues te)) + } + +-- * Update specs using commands + +data Command = Up Int + | Down Int + | Noop + deriving (Eq, Read, Show) + +apply :: Core.Spec -> String -> Command -> Core.Spec +apply spec name command = spec + { Core.specStreams = + map (updateStream name command) (Core.specStreams spec) + , Core.specObservers = + map (updateObserver name command) (Core.specObservers spec) + , Core.specTriggers = + map (updateTrigger name command) (Core.specTriggers spec) + } + +updateObserver :: String -> Command -> Core.Observer -> Core.Observer +updateObserver name command (Core.Observer i e ty) = (Core.Observer i e' ty) + where + e' = updateExpr name command e + +updateTrigger :: String -> Command -> Core.Trigger -> Core.Trigger +updateTrigger name command (Core.Trigger i e es) = (Core.Trigger i e' es') + where + e' = updateExpr name command e + es' = map (updateUExpr name command) es + +updateExpr :: String -> Command -> Core.Expr a -> Core.Expr a +updateExpr name command e = case e of + (Core.ExternVar ty nameE vs) + | nameE Prelude.== name + -> Core.ExternVar ty nameE (updateValues vs ty command) + | otherwise + -> e + (Core.Op1 op e) -> + Core.Op1 op (updateExpr name command e) + (Core.Op2 op e1 e2) -> + Core.Op2 op (updateExpr name command e1) (updateExpr name command e2) + (Core.Op3 op e1 e2 e3) -> + Core.Op3 + op + (updateExpr name command e1) + (updateExpr name command e2) + (updateExpr name command e3) + _ -> e + +updateUExpr :: String -> Command -> Core.UExpr -> Core.UExpr +updateUExpr name cmd (Core.UExpr ty e) = Core.UExpr ty (updateExpr name cmd e) + +updateStream :: String -> Command -> Core.Stream -> Core.Stream +updateStream name command (Core.Stream i b e ty) = + (Core.Stream i b (updateExpr name command e) ty) + +updateValues :: Maybe [a] -> Type a -> Command -> Maybe [a] +updateValues vsM ty command = + fmap (\vs -> fmap (updateValue command ty) (zip [0..] vs)) vsM + +updateValue :: Command -> Type a -> (Int, a) -> a +updateValue (Up n) Core.Bool (ix, a) = if n Prelude.== ix then Prelude.not a else a +updateValue (Down n) Core.Bool (ix, a) = if n Prelude.== ix then Prelude.not a else a +updateValue (Up n) Core.Word8 (ix, a) = if n Prelude.== ix then a + 1 else a +updateValue (Down n) Core.Word8 (ix, a) = if n Prelude.== ix then a - 1 else a +updateValue _ _ (ix, a) = a + +-- * Sample spec + +-- External temperature as a byte, range of -50C to 100C +temp :: Stream Word8 +temp = extern "temperature" (Just [0, 15, 20, 25, 30]) + +-- Calculate temperature in Celsius. +-- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there +-- is no direct relation between Word8 and Float. +ctemp :: Stream Float +ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 + +trueFalse :: Stream Bool +trueFalse = [True] ++ not trueFalse + +spec = do + -- Triggers that fire when the ctemp is too low or too high, + -- pass the current ctemp as an argument. + trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1), arg trueFalse] + trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] + observer "temperature" temp + observer "temperature2" (temp + 1) From 04c1a7553f693483f3bd7686fdbbdc4358ead363 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 01:14:47 +0000 Subject: [PATCH 22/32] Add a stream dynamically. It only works for Stream Float atm. --- copilot-visualizer.cabal | 31 ++++++++++++++++++ main.html | 11 +++++-- src/Copilot/Live.hs | 69 ++++++++++++++++++++++++++++++---------- 3 files changed, 92 insertions(+), 19 deletions(-) diff --git a/copilot-visualizer.cabal b/copilot-visualizer.cabal index e19197b..726aa89 100644 --- a/copilot-visualizer.cabal +++ b/copilot-visualizer.cabal @@ -32,6 +32,37 @@ source-repository head location: https://github.com/Copilot-Language/copilot.git subdir: copilot-visualizer +executable copilot-live-backend + default-language: Haskell2010 + + main-is: Copilot/Live.hs + + hs-source-dirs: src + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + aeson, + directory, + filepath, + hint, + pretty >= 1.0 && < 1.2, + ogma-extra >= 1.6.0 && < 1.7, + + copilot-core >= 4.2 && < 4.3, + copilot-interpreter >= 4.2 && < 4.3, + copilot-visualizer >= 4.2 && < 4.3, + copilot-language, + copilot, + text, + websockets >= 0.12.7 + + other-modules: + + Paths_copilot_visualizer + library default-language: Haskell2010 diff --git a/main.html b/main.html index 8930e51..f982740 100644 --- a/main.html +++ b/main.html @@ -64,6 +64,7 @@ + diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index ed9eb08..f6cf5c0 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -5,19 +5,25 @@ import Control.Concurrent import Control.Concurrent.MVar -import Control.Exception ( finally ) +import Control.Exception (finally) import Control.Monad -import qualified Copilot.Core as Core +import qualified Copilot.Core as Core import Copilot.Interpret.Eval -import qualified Copilot.Visualize as View +import Copilot.Language hiding (interpret, typeOf) +import qualified Copilot.Language +import qualified Copilot.Visualize as View import Data.Aeson -import qualified Data.Text as T +import Data.List hiding ((++)) +import qualified Data.Text as T import Data.Typeable import GHC.Generics import Language.Copilot -import qualified Network.WebSockets as WS -import Prelude hiding ( div, not, (++), (<), (>) ) +import Language.Copilot hiding (interpret, typeOf) +import qualified Language.Haskell.Interpreter as HI +import qualified Network.WebSockets as WS +import Prelude hiding (div, not, (++), (<), (>)) import qualified Prelude +import System.Directory main :: IO () main = do @@ -49,17 +55,19 @@ app spec pending = do loop conn v = forever $ do msg <- WS.receiveData conn - let (command, name) = - case T.unpack msg of - ('U':'p':' ':d:' ':s) -> (Up (read [d]), s) - ('D':'o':'w':'n':' ':d:' ':s) -> (Down (read [d]), s) - v -> (Noop, v) + print msg + let (command, name) = read (T.unpack msg) + -- case of + -- ('U':'p':' ':d:' ':s) -> (Up (read [d]), s) + -- ('D':'o':'w':'n':' ':d:' ':s) -> (Down (read [d]), s) + -- v -> (Noop, v) + print command (k, spec') <- takeMVar v - let spec'' = case T.unpack msg of - "StepUp" -> spec' - "StepDown" -> spec' - _ -> apply spec' name command + spec'' <- case T.unpack msg of + "StepUp" -> pure spec' + "StepDown" -> pure spec' + _ -> apply spec' name command let k' = case T.unpack msg of "StepUp" -> k + 1 @@ -114,11 +122,20 @@ toTraceElem te = TraceElem data Command = Up Int | Down Int + | AddStream String String | Noop deriving (Eq, Read, Show) -apply :: Core.Spec -> String -> Command -> Core.Spec -apply spec name command = spec +apply :: Core.Spec -> String -> Command -> IO Core.Spec +apply spec name (AddStream sName sExpr) = do + putStrLn "Here" + spec' <- addStream sName sExpr + putStrLn "Here 2" + let observers' = Core.specObservers spec' + observers = Core.specObservers spec + return $ spec { Core.specObservers = observers Prelude.++ observers' } + +apply spec name command = pure $ spec { Core.specStreams = map (updateStream name command) (Core.specStreams spec) , Core.specObservers = @@ -197,3 +214,21 @@ spec = do trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] observer "temperature" temp observer "temperature2" (temp + 1) + +addStream :: String -> String -> IO (Core.Spec) +addStream name expr = do + r <- HI.runInterpreter (addStream' name expr) + case r of + Left err -> error $ show err + Right spec -> return spec + +-- observe that Interpreter () is an alias for InterpreterT IO () +addStream' :: String -> String -> HI.Interpreter Core.Spec +addStream' name expr = do + HI.setImportsQ [ ("Prelude", Nothing) + , ("Copilot.Language", Nothing) + , ("Language.Copilot", Nothing) + ] + a_stream <- HI.interpret expr (HI.as :: Stream Float) + let spec = observer name a_stream + HI.liftIO $ reify spec From c3abfa120053fc9a9f711b35d94e4163653add43 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 02:16:37 +0000 Subject: [PATCH 23/32] Modify backend to insert any stream of any type. --- src/Copilot/Live.hs | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index f6cf5c0..e9774c4 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -5,7 +5,7 @@ import Control.Concurrent import Control.Concurrent.MVar -import Control.Exception (finally) +import Control.Exception (handle, SomeException(..), finally) import Control.Monad import qualified Copilot.Core as Core import Copilot.Interpret.Eval @@ -20,6 +20,7 @@ import GHC.Generics import Language.Copilot import Language.Copilot hiding (interpret, typeOf) import qualified Language.Haskell.Interpreter as HI +import qualified Language.Haskell.Interpreter.Unsafe as HI import qualified Network.WebSockets as WS import Prelude hiding (div, not, (++), (<), (>)) import qualified Prelude @@ -219,16 +220,30 @@ addStream :: String -> String -> IO (Core.Spec) addStream name expr = do r <- HI.runInterpreter (addStream' name expr) case r of - Left err -> error $ show err + Left err -> do putStrLn $ "There was an error, and here it is: " Prelude.++ show err + error $ show err Right spec -> return spec -- observe that Interpreter () is an alias for InterpreterT IO () addStream' :: String -> String -> HI.Interpreter Core.Spec addStream' name expr = do HI.setImportsQ [ ("Prelude", Nothing) - , ("Copilot.Language", Nothing) - , ("Language.Copilot", Nothing) - ] - a_stream <- HI.interpret expr (HI.as :: Stream Float) - let spec = observer name a_stream + , ("Copilot.Language", Nothing) + , ("Copilot.Language.Spec", Nothing) + , ("Language.Copilot", Nothing) + , ("Data.Functor.Identity", Nothing) + , ("Control.Monad.Writer", Nothing) + ] + + -- For debugging purposes only: let completeExpr = "observer \"h1\" (constF 3.0)" + let completeExpr = concat [ "observer " + , show name + , " (" + , expr + , ")" + ] + + -- HI.liftIO $ putStrLn $ "I'm about to interpret " ++ completeExpr + spec <- HI.interpret completeExpr (HI.as :: Spec) + -- HI.liftIO $ putStrLn "completed" HI.liftIO $ reify spec From 5139a3db9c589d05a4ca274be98170bbe509363a Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 02:49:44 +0000 Subject: [PATCH 24/32] Add streams dynamically. Streams must be independent (cannot use other streams in the spec) --- main.html | 34 +++++++++++++++++++++++++++++++++- src/Copilot/Live.hs | 32 ++++++++++++++++++-------------- 2 files changed, 51 insertions(+), 15 deletions(-) diff --git a/main.html b/main.html index f982740..01ffe29 100644 --- a/main.html +++ b/main.html @@ -66,6 +66,22 @@ + + diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index e9774c4..ac357b4 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -25,6 +25,7 @@ import qualified Network.WebSockets as WS import Prelude hiding (div, not, (++), (<), (>)) import qualified Prelude import System.Directory +import Text.Read main :: IO () main = do @@ -39,36 +40,39 @@ makeTraceEval' k spec' = app :: Spec -> WS.ServerApp app spec pending = do conn <- WS.acceptRequest pending - WS.withPingThread conn 30 (return ()) $ do - spec' <- reify spec + WS.withPingThread conn 30 (return ()) $ + handle (\(e :: SomeException) -> do putStrLn $ "Something went wrong:" Prelude.++ show e + error $ show e) $ do + spec' <- reify spec - let k = 3 + let k = 3 - v <- newMVar (k, spec') + v <- newMVar (k, spec') - let a = makeTraceEval' k spec' - samples = encode $ toJSON $ allSamples a - WS.sendTextData conn samples + let a = makeTraceEval' k spec' + samples = encode $ toJSON $ allSamples a + WS.sendTextData conn samples - loop conn v + loop conn v where loop conn v = forever $ do msg <- WS.receiveData conn print msg - let (command, name) = read (T.unpack msg) + let pair = readMaybe (T.unpack msg) -- case of -- ('U':'p':' ':d:' ':s) -> (Up (read [d]), s) -- ('D':'o':'w':'n':' ':d:' ':s) -> (Down (read [d]), s) -- v -> (Noop, v) - print command + print pair (k, spec') <- takeMVar v - spec'' <- case T.unpack msg of - "StepUp" -> pure spec' - "StepDown" -> pure spec' - _ -> apply spec' name command + spec'' <- case (T.unpack msg, pair) of + ("StepUp", _) -> pure spec' + ("StepDown", _) -> pure spec' + (_, Just (command, name)) -> apply spec' name command + _ -> pure spec' let k' = case T.unpack msg of "StepUp" -> k + 1 From 6628888e16e633a45acd6231bb941a71a56406d0 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 03:00:14 +0000 Subject: [PATCH 25/32] Import Prelude qualified. --- src/Copilot/Live.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index ac357b4..b9e06e4 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -231,7 +231,7 @@ addStream name expr = do -- observe that Interpreter () is an alias for InterpreterT IO () addStream' :: String -> String -> HI.Interpreter Core.Spec addStream' name expr = do - HI.setImportsQ [ ("Prelude", Nothing) + HI.setImportsQ [ ("Prelude", Just "P") , ("Copilot.Language", Nothing) , ("Copilot.Language.Spec", Nothing) , ("Language.Copilot", Nothing) From 006ed906ee413fab47b0b0b77b6089730a4fc36e Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 03:02:37 +0000 Subject: [PATCH 26/32] Alignment --- src/Copilot/Live.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index b9e06e4..4984d24 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -94,16 +94,19 @@ data Data = Data instance ToJSON Data data TraceElem = TraceElem - { teName :: String + { teName :: String , teIsBoolean :: Bool - , teValues :: [Sample] + , teValues :: [Sample] } deriving (Generic) instance ToJSON TraceElem data Sample = Sample - { time :: Int, value :: String, duration :: Float } + { time :: Int + , value :: String + , duration :: Float + } deriving (Generic) instance ToJSON Sample From ccfce62189d48b52ae878a2075240bab8b38bed9 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 03:05:34 +0000 Subject: [PATCH 27/32] Add tODO note --- src/Copilot/Live.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index 4984d24..c156445 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -139,6 +139,9 @@ apply spec name (AddStream sName sExpr) = do putStrLn "Here" spec' <- addStream sName sExpr putStrLn "Here 2" + -- TODO: I need to bring the streams from the other spec too, otherwise the + -- streams to include may refer to streams by ID that are in a different + -- scope. let observers' = Core.specObservers spec' observers = Core.specObservers spec return $ spec { Core.specObservers = observers Prelude.++ observers' } @@ -212,13 +215,13 @@ temp = extern "temperature" (Just [0, 15, 20, 25, 30]) ctemp :: Stream Float ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 -trueFalse :: Stream Bool -trueFalse = [True] ++ not trueFalse +-- trueFalse :: Stream Bool +-- trueFalse = [True] ++ not trueFalse spec = do -- Triggers that fire when the ctemp is too low or too high, -- pass the current ctemp as an argument. - trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1), arg trueFalse] + trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1)] -- , arg trueFalse] trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] observer "temperature" temp observer "temperature2" (temp + 1) From 1e165713691cc1e2ce818e8a1981bdafb83dcaf1 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 15 Mar 2025 13:23:34 +0000 Subject: [PATCH 28/32] Remove commented code --- src/Copilot/Live.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index c156445..3a23a81 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -61,10 +61,6 @@ app spec pending = do msg <- WS.receiveData conn print msg let pair = readMaybe (T.unpack msg) - -- case of - -- ('U':'p':' ':d:' ':s) -> (Up (read [d]), s) - -- ('D':'o':'w':'n':' ':d:' ':s) -> (Down (read [d]), s) - -- v -> (Noop, v) print pair (k, spec') <- takeMVar v From f87cd1c2bd4be15c2ef2d9d88ae0f1407d05ec0e Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 16 Mar 2025 08:13:31 +0000 Subject: [PATCH 29/32] Implement ability to extract a trace from a spec, and restore a trace in a spec --- src/Copilot/Live.hs | 104 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 104 insertions(+) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index 3a23a81..16898cc 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -14,7 +14,9 @@ import qualified Copilot.Language import qualified Copilot.Visualize as View import Data.Aeson import Data.List hiding ((++)) +import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Type.Equality as DE import Data.Typeable import GHC.Generics import Language.Copilot @@ -253,3 +255,105 @@ addStream' name expr = do spec <- HI.interpret completeExpr (HI.as :: Spec) -- HI.liftIO $ putStrLn "completed" HI.liftIO $ reify spec + +data Trace = Trace + { traceMap :: [ (String, UValues) ] + } + +data UValues = forall a . Typeable a => UValues + { uvType :: Core.Type a + , uvValues :: [ a ] + } + +extractTrace :: Core.Spec -> Trace +extractTrace spec = Trace $ concat $ concat + [ fmap extractTraceStream (Core.specStreams spec) + , fmap extractTraceObserver (Core.specObservers spec) + , fmap extractTraceTrigger (Core.specTriggers spec) + ] + +extractTraceStream :: Core.Stream -> [ (String, UValues) ] +extractTraceStream (Core.Stream _id _buf expr _ty) = + extractTraceExpr expr + +extractTraceObserver :: Core.Observer -> [ (String, UValues) ] +extractTraceObserver (Core.Observer _name expr _ty) = + extractTraceExpr expr + +extractTraceTrigger :: Core.Trigger -> [ (String, UValues) ] +extractTraceTrigger (Core.Trigger _name expr args) = concat $ + extractTraceExpr expr + : fmap extractTraceUExpr args + +extractTraceExpr :: Core.Expr a -> [ (String, UValues) ] +extractTraceExpr (Core.Local _ _ _ expr1 expr2) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + ] +extractTraceExpr (Core.ExternVar ty name values) = + [ (name, UValues ty (fromMaybe [] values)) ] +extractTraceExpr (Core.Op1 _op expr) = + extractTraceExpr expr +extractTraceExpr (Core.Op2 _op expr1 expr2) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + ] +extractTraceExpr (Core.Op3 _op expr1 expr2 expr3) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + , extractTraceExpr expr3 + ] +extractTraceExpr (Core.Label _ty _lbl expr) = + extractTraceExpr expr +extractTraceExpr _ = [] + +extractTraceUExpr :: Core.UExpr -> [ (String, UValues) ] +extractTraceUExpr (Core.UExpr ty expr) = + extractTraceExpr expr + +updateWithTrace :: Trace -> Core.Spec -> Core.Spec +updateWithTrace trace spec = spec + { Core.specStreams = fmap (updateWithTraceStream trace) (Core.specStreams spec) + , Core.specObservers = fmap (updateWithTraceObserver trace) (Core.specObservers spec) + , Core.specTriggers = fmap (updateWithTraceTrigger trace) (Core.specTriggers spec) + } + +updateWithTraceStream :: Trace -> Core.Stream -> Core.Stream +updateWithTraceStream trace (Core.Stream ident buf expr ty) = + Core.Stream ident buf (updateWithTraceExpr trace expr) ty + +updateWithTraceObserver :: Trace -> Core.Observer -> Core.Observer +updateWithTraceObserver trace (Core.Observer name expr ty) = + Core.Observer name (updateWithTraceExpr trace expr) ty + +updateWithTraceTrigger :: Trace -> Core.Trigger -> Core.Trigger +updateWithTraceTrigger trace (Core.Trigger name expr args) = + Core.Trigger name (updateWithTraceExpr trace expr) (fmap (updateWithTraceUExpr trace) args) + +updateWithTraceExpr :: Trace -> Core.Expr a -> Core.Expr a +updateWithTraceExpr trace (Core.Local ty1 ty2 name expr1 expr2) = + Core.Local ty1 ty2 name (updateWithTraceExpr trace expr1) (updateWithTraceExpr trace expr2) +updateWithTraceExpr trace (Core.ExternVar ty name values) = + Core.ExternVar ty name values' + where + values' | Just (UValues ty2 vals) <- lookup name (traceMap trace) + , Just DE.Refl <- DE.testEquality ty ty2 + = Just vals + | otherwise + = values +updateWithTraceExpr trace (Core.Op1 op expr) = + Core.Op1 op (updateWithTraceExpr trace expr) +updateWithTraceExpr trace (Core.Op2 op expr1 expr2) = + Core.Op2 op (updateWithTraceExpr trace expr1) (updateWithTraceExpr trace expr2) +updateWithTraceExpr trace (Core.Op3 op expr1 expr2 expr3) = + Core.Op3 op + (updateWithTraceExpr trace expr1) + (updateWithTraceExpr trace expr2) + (updateWithTraceExpr trace expr3) +updateWithTraceExpr trace (Core.Label ty lbl expr) = + Core.Label ty lbl (updateWithTraceExpr trace expr) +updateWithTraceExpr trace x = x + +updateWithTraceUExpr :: Trace -> Core.UExpr -> Core.UExpr +updateWithTraceUExpr trace (Core.UExpr ty expr) = + Core.UExpr ty (updateWithTraceExpr trace expr) From 01543be9f15becaaa42f7cc48ff3d9b73195c3d2 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 16 Mar 2025 08:16:20 +0000 Subject: [PATCH 30/32] Implement spec dependences in where clause so that it's easier to turn into one string --- src/Copilot/Live.hs | 30 ++++++++++++------------------ 1 file changed, 12 insertions(+), 18 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index 16898cc..b89e2ff 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -203,26 +203,20 @@ updateValue _ _ (ix, a) = a -- * Sample spec --- External temperature as a byte, range of -50C to 100C -temp :: Stream Word8 -temp = extern "temperature" (Just [0, 15, 20, 25, 30]) - --- Calculate temperature in Celsius. --- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there --- is no direct relation between Word8 and Float. -ctemp :: Stream Float -ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 +spec = do + trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1), arg trueFalse] + trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] + observer "temperature" temp + observer "temperature2" (temp + 1) + where + temp :: Stream Word8 + temp = extern "temperature" (Just [0, 15, 20, 25, 30]) --- trueFalse :: Stream Bool --- trueFalse = [True] ++ not trueFalse + ctemp :: Stream Float + ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 -spec = do - -- Triggers that fire when the ctemp is too low or too high, - -- pass the current ctemp as an argument. - trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1)] -- , arg trueFalse] - trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] - observer "temperature" temp - observer "temperature2" (temp + 1) + trueFalse :: Stream Bool + trueFalse = [True] ++ not trueFalse addStream :: String -> String -> IO (Core.Spec) addStream name expr = do From 4fa720e36301179b9d8d305c5770577e9d08cf19 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 16 Mar 2025 18:30:04 +0000 Subject: [PATCH 31/32] Add streams dynamically that refer to existing streams --- src/Copilot/Live.hs | 75 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 57 insertions(+), 18 deletions(-) diff --git a/src/Copilot/Live.hs b/src/Copilot/Live.hs index b89e2ff..e4fed16 100644 --- a/src/Copilot/Live.hs +++ b/src/Copilot/Live.hs @@ -32,34 +32,35 @@ import Text.Read main :: IO () main = do putStrLn "WebSocket server starting on port 9160..." - WS.runServer "127.0.0.1" 9160 (app spec) + WS.runServer "127.0.0.1" 9160 app makeTraceEval' k spec' = View.makeTraceEval k spec' (eval Haskell k spec') -- * App -app :: Spec -> WS.ServerApp -app spec pending = do +app :: WS.ServerApp +app pending = do conn <- WS.acceptRequest pending WS.withPingThread conn 30 (return ()) $ handle (\(e :: SomeException) -> do putStrLn $ "Something went wrong:" Prelude.++ show e error $ show e) $ do - spec' <- reify spec + spec' <- readSpec spec let k = 3 + specV <- newMVar spec v <- newMVar (k, spec') let a = makeTraceEval' k spec' samples = encode $ toJSON $ allSamples a WS.sendTextData conn samples - loop conn v + loop conn v specV where - loop conn v = forever $ do + loop conn v specV = forever $ do msg <- WS.receiveData conn print msg let pair = readMaybe (T.unpack msg) @@ -69,6 +70,21 @@ app spec pending = do spec'' <- case (T.unpack msg, pair) of ("StepUp", _) -> pure spec' ("StepDown", _) -> pure spec' + (_, Just (AddStream name expr, _)) -> do + spec <- takeMVar specV + let specN = spec Prelude.++ "\n" Prelude.++ + " " Prelude.++ completeExpr + completeExpr = concat [ "observer " + , show name + , " (" + , expr + , ")" + ] + let trace = extractTrace spec' + spec2 <- readSpec specN + putMVar specV specN + let spec3 = updateWithTrace trace spec2 + return spec3 (_, Just (command, name)) -> apply spec' name command _ -> pure spec' @@ -203,20 +219,43 @@ updateValue _ _ (ix, a) = a -- * Sample spec -spec = do - trigger "heaton" (temp < 18) [arg ctemp, arg (constI16 1), arg trueFalse] - trigger "heatoff" (temp > 21) [arg (constI16 1), arg ctemp] - observer "temperature" temp - observer "temperature2" (temp + 1) - where - temp :: Stream Word8 - temp = extern "temperature" (Just [0, 15, 20, 25, 30]) +spec :: String +spec = unlines + [ "let temperature :: Stream Word8" + , " temperature = extern \"temperature\" (Just [0, 15, 20, 25, 30])" + , "" + , " ctemp :: Stream Float" + , " ctemp = (unsafeCast temperature) * (150.0 / 255.0) - 50.0" + , "" + , " trueFalse :: Stream Bool" + , " trueFalse = [True] ++ not trueFalse" + , "" + , "in do trigger \"heaton\" (temperature < 18) [arg ctemp, arg (constI16 1), arg trueFalse]" + , " trigger \"heatoff\" (temperature > 21) [arg (constI16 1), arg ctemp]" + , " observer \"temperature\" temperature" + , " observer \"temperature2\" (temperature + 1)" + ] - ctemp :: Stream Float - ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 +spec' :: String -> HI.Interpreter Core.Spec +spec' spec = do + HI.setImportsQ [ ("Prelude", Just "P") + , ("Copilot.Language", Nothing) + , ("Copilot.Language.Spec", Nothing) + , ("Language.Copilot", Nothing) + , ("Data.Functor.Identity", Nothing) + , ("Control.Monad.Writer", Nothing) + ] - trueFalse :: Stream Bool - trueFalse = [True] ++ not trueFalse + spec' <- HI.interpret spec (HI.as :: Spec) + HI.liftIO $ reify spec' + +readSpec :: String -> IO Core.Spec +readSpec spec = do + r <- HI.runInterpreter (spec' spec) + case r of + Left err -> do putStrLn $ "There was an error, and here it is: " Prelude.++ show err + error $ show err + Right s -> return s addStream :: String -> String -> IO (Core.Spec) addStream name expr = do From 556127dee255de597aa30a80155a27f9372fc489 Mon Sep 17 00:00:00 2001 From: kaBeech Date: Sat, 22 Mar 2025 16:42:47 -0700 Subject: [PATCH 32/32] Distinguish colors in reduced color conditions Makes colored backgrounds more easily distinguishable in conditions with reduced color. Increases blue content in the 'false' color to increase distinction from the 'true' color in protanopic (no red) and deuteranopic (no green). Decreases red content in the 'false' color to increase distinction from the 'true' color in achromatopsic (no color) conditions. Does not meaningfully address visibility considerations in reduced contrast or blurry conditions. --- data/timeline.html | 2 +- main.html | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/data/timeline.html b/data/timeline.html index 2160ec8..e19cafc 100644 --- a/data/timeline.html +++ b/data/timeline.html @@ -152,7 +152,7 @@ .attr("y", 0) .attr("width", d => xScale(d.duration) - xScale(0)) .attr("height", rowHeight) - .attr("fill", d => d.value ? "#90EE90" : "#FFB6C1"); + .attr("fill", d => d.value ? "#90EE90" : "#E1B6ED"); }; // Draw numeric row with stretched hexagons diff --git a/main.html b/main.html index 01ffe29..2966ad2 100644 --- a/main.html +++ b/main.html @@ -190,7 +190,7 @@

Enter new stream details

.attr("y", 0) .attr("width", d => xScale(d.duration) - xScale(0)) .attr("height", rowHeight) - .attr("fill", d => d.value == "true" ? "#90EE90" : "#FFB6C1"); + .attr("fill", d => d.value == "true" ? "#90EE90" : "#E1B6ED"); } function redraw()