array-forth 0.2.0.5 → 0.2.0.6
raw patch · 8 files changed
+335/−72 lines, 8 filesdep +Chartnew-component:exe:chart
Dependencies added: Chart
Files
- array-forth.cabal +7/−1
- src/Chart.hs +141/−0
- src/Language/ArrayForth/Distance.hs +20/−14
- src/Language/ArrayForth/Interpreter.hs +47/−20
- src/Language/ArrayForth/State.hs +8/−3
- src/Language/ArrayForth/Synthesis.hs +61/−15
- src/Main.hs +50/−18
- src/Run.hs +1/−1
array-forth.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.5+version: 0.2.0.6 -- A short (one-line) description of the package. synopsis: A simple interpreter for arrayForth, the language used on GreenArrays chips.@@ -80,6 +80,12 @@ Main-is: src/Run.hs build-depends: base >3 && <=5, vector ==0.9.*, split ==0.1.*, array-forth GHC-options: -Wall -rtsopts++executable chart+ Main-is: src/Chart.hs+ build-depends: base >3 && <=5, mcmc-synthesis >=0.1, array-forth, Chart >=0.16,+ MonadRandom ==0.1.*, optparse-applicative ==0.5.*+ GHC-options: -Wall -rtsopts -O2 test-suite test-array-forth Type: exitcode-stdio-1.0
+ src/Chart.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Arrow ((&&&))+import Control.Monad.Random (evalRandIO)++import Data.Bits (complement)+import Data.Functor ((<$>))+import Data.Function (on)+import Data.List+import Data.Monoid ((<>), Sum (..), Monoid)++import Graphics.Rendering.Chart.Simple++import Language.ArrayForth.Distance (Distance, matching, registers)+import Language.ArrayForth.Interpreter (eval)+import Language.ArrayForth.Parse ()+import Language.ArrayForth.Program (Program, load, readProgram)+import qualified Language.ArrayForth.Stack as S+import Language.ArrayForth.State (State (..), startState)+import Language.ArrayForth.Synthesis (DefaultScore (..),+ defaultMutations, defaultOps,+ evaluate, trace, withPerformance)+import qualified Language.Synthesis.Distribution as Distr+import Language.Synthesis.Synthesis (Problem (..), Score (..),+ runningBest, synthesizeMhList)++import Options.Applicative++import Text.Printf++data Options = Options { out :: Maybe FilePath+ , problem :: Problem Program DefaultScore+ , points, resolution :: Int+ , maxScore :: Maybe Double }++options :: Parser Options+options = Options+ <$> nullOption (long "out"+ <> short 'o'+ <> value Nothing+ <> metavar "PATH"+ <> reader (return . Just)+ <> help "Filepath for the resulting chart.")+ <*> nullOption (long "problem"+ <> short 'p'+ <> value inclusiveOr+ <> metavar "NAME"+ <> reader parseProblem+ <> help problemHelp)+ <*> option (long "samples"+ <> short 's'+ <> value 2500+ <> metavar "SAMPLES"+ <> help "The number of samples to take. Each sample corresponds to something like ~6k programs considered.")+ <*> option (long "resolution"+ <> short 'r'+ <> value 25+ <> metavar "N"+ <> help "Sample every N generated candidate programs.")+ <*> nullOption (long "max"+ <> short 'x'+ <> value Nothing+ <> metavar "MAX_SCORE"+ <> reader (return . Just . read)+ <> help "Stop at the given score.")++-- I wish existential types were better :/+problems :: [(String, Problem Program DefaultScore)]+problems = [("traceOr", traceOr), ("inclusiveOr", inclusiveOr)]++problemHelp :: String+problemHelp = printf "The problem to run. Currently, the valid choices are:\n%s" names+ where names = init . unlines $ map (((replicate 30 ' ' ++ "- ") ++ ) . fst) problems++parseProblem :: String -> Either ParseError (Problem Program DefaultScore)+parseProblem problem = case lookup problem problems of+ Just p -> return p+ Nothing -> Left . ErrorMsg $ printf "Problem name %s is not recognized." problem++range :: [Double]+range = [0..]++main :: IO ()+main = execParser go >>= run+ where go = info (helper <*> options)+ (fullDesc+ <> progDesc "Synthesize arrayForth programs using different strategies and graph the performances of the evaluation function."+ <> header "chart - chart the performance of MCMC synthesis")++good :: Score s => (Program, s) -> Bool+good (_, val) = toScore val >= 0++run :: Options -> IO ()+run Options {..} =+ do programs <- evalRandIO $ synthesizeMhList problem+ let getMax = maybe id (takeWhile . (<)) maxScore+ process = take points . sample resolution . movingAvg (2 * resolution) . drop 10+ results = snd . head <$> group programs+ scores = process . getMax $ map toScore results+ correctness = take (length scores) . process $ map corr results+ printf "Result: %s.\n" . show $ programs !! (resolution * points)+ case out of+ Just filepath -> plotPDF filepath range scores Solid correctness Solid+ Nothing -> return ()++corr :: DefaultScore -> Double+corr (DefaultScore a _) = a++sample :: Int -> [a] -> [a]+sample _ [] = []+sample n (x:xs) = x : sample n (drop n xs)++movingAvg :: Fractional a => Int -> [a] -> [a]+movingAvg _ [] = [0]+movingAvg window ls@(_:xs) = (sum start / genericLength start) : movingAvg window xs+ where start = take window ls++cases :: [State]+cases = [startState {t = 0, s = 123}, startState {t = maxBound, s = 123},+ startState {t = 1, s = 123}, startState {t = maxBound - 1, s = 123},+ startState {t = 37, s = 123}, startState {t = 52, s = 123}]+ +orSpec :: Program+orSpec = "over over or a! and a or"++inclusiveOr :: Problem Program DefaultScore+inclusiveOr = Problem { score = evaluate orSpec cases distance+ , prior = Distr.constant orSpec+ , jump = defaultMutations }+ where complemented σ₁ σ₂@State {t = t₂} =+ Sum . negate . getSum . registers [t] σ₁ $ σ₂ {t = complement t₂}+ distance = registers [t] ++traceOr :: Problem Program DefaultScore+traceOr = Problem { score = trace orSpec cases $ withPerformance sc+ , prior = Distr.constant orSpec+ , jump = defaultMutations }+ where sc = matching (s &&& t) <> (registers [t] `on` last)
src/Language/ArrayForth/Distance.hs view
@@ -1,32 +1,38 @@+{-# LANGUAGE FlexibleInstances #-} module Language.ArrayForth.Distance where -import Data.Bits (Bits, popCount, xor)+import Data.Bits (Bits, popCount, xor)+import Data.List (genericLength)+import Data.Monoid -import Language.ArrayForth.Opcode (F18Word)+import Language.ArrayForth.Interpreter (Trace)+import Language.ArrayForth.Opcode (F18Word) import Language.ArrayForth.State --- | A function that computes a measure of "distance" between two--- states. The larger the returned number, the more different the--- states.-type Distance = State -> State -> Double+import Language.Synthesis.Synthesis (Score (..)) +type Distance = Sum Double++instance Score Distance where toScore = getSum+ -- | Counts the number of bits that differ between two numbers. countBits :: (Integral n, Bits n) => n -> n -> Int countBits n₁ n₂ = popCount $ (fromIntegral n₁ :: Int) `xor` fromIntegral n₂ -- | Return a distance function that counts the different bits between -- the given registers. You could use it like `compareRegisters [s, t]`.-registers :: [State -> F18Word] -> Distance-registers regs s₁ s₂ = fromIntegral . sum $ zipWith countBits (go s₁) (go s₂)+registers :: [State -> F18Word] -> (State -> State -> Distance)+registers regs s₁ s₂ = Sum . fromIntegral . sum $ zipWith countBits (go s₁) (go s₂) where go state = map ($ state) regs -- | Returns a distance function that counts the different bits -- between the given memory locations.-locations :: [F18Word] -> Distance-locations addresses s₁ s₂ = fromIntegral . sum $ zipWith countBits (go s₁) (go s₂)+locations :: [F18Word] -> (State -> State -> Distance)+locations addresses s₁ s₂ = Sum . fromIntegral . sum $ zipWith countBits (go s₁) (go s₂) where go state = map (memory state !) addresses --- | Combines multiple distance functions to create a new one, by--- summing the different distances.-distances :: [Distance] -> Distance-distances dists s₁ s₂ = sum [dist s₁ s₂ | dist <- dists]+-- | Returns a score that counts the number of matching states+-- according to some projection function.+matching :: Eq a => (State -> a) -> (Trace -> Trace -> Distance)+matching f t₁ t₂ = Sum $ -(genericLength t₂ - resultLength)+ where resultLength = genericLength $ filter (`elem` map f t₁) (map f t₂)
src/Language/ArrayForth/Interpreter.hs view
@@ -9,33 +9,54 @@ import Language.ArrayForth.Opcode import Language.ArrayForth.State --- | Runs a single word's worth of instructions starting from the given state.+-- | A trace of a progam is the state after every word is executed.+type Trace = [State]++-- | Runs a single word's worth of instructions starting from the+-- given state, returning the intermediate states for each executed+-- opcode.+wordAll :: Instrs -> State -> [State]+wordAll (Instrs a b c d) state =+ let s₁ = [execute a state]+ s₂ = if endWord a then s₁ else run b s₁+ s₃ = if endWord a || endWord b+ then s₂ else run c s₂ in+ if endWord a || endWord b || endWord c then s₃ else s₃ ++ run d s₃+wordAll (Jump3 a b c addr) state = let s₁ = [execute a state]+ s₂ = if endWord a then s₁ else run b s₁ in+ if endWord a || endWord b+ then s₂ else s₂ ++ [jump c addr (last s₂)]+wordAll (Jump2 a b addr) state = let s' = execute a state in+ if endWord a then [s'] else [s', jump b addr s']+wordAll (Jump1 a addr) state = [jump a addr state]+wordAll (Constant _) _ = error "Cannot execute a constant!"++-- | Runs a single word's worth of instructions, returning only the+-- final state. word :: Instrs -> State -> State-word (Instrs a b c d) state = let s₁ = execute a state- s₂ = if endWord a then s₁ else execute b s₁- s₃ = if endWord a || endWord b- then s₂ else execute c s₂ in- if endWord a || endWord b || endWord c then s₃ else execute d s₃-word (Jump3 a b c addr) state = let s₁ = execute a state- s₂ = if endWord a then s₁ else execute b s₁ in- if endWord a || endWord b then s₂ else jump c addr s₂-word (Jump2 a b addr) state = let s' = execute a state in- if endWord a then s' else jump b addr s'-word (Jump1 a addr) state = jump a addr state-word (Constant _) _ = error "Cannot execute a constant!"+word instr σ = last $ wordAll instr σ --- | Executes a single instruction in the given state, incrementing--- the program counter.+-- | Executes a single word in the given state, incrementing+-- the program counter and returning all the intermediate states.+stepAll :: State -> [State]+stepAll state@State {p} = wordAll (next state) $ state {p = p + 1, i = toBits $ next state}++-- | Executes a single word in the given state, returning the last+-- resulting state.q step :: State -> State-step state@State {p} = word (next state) $ state {p = p + 1, i = toBits $ next state}+step = last . stepAll +-- | Trace the given program, including all the intermediate states.+traceAll :: State -> Trace+traceAll program = let steps = stepAll program in steps ++ traceAll (last steps)+ -- | Returns a trace of the program's execution. The trace is a list -- of the state of the chip after each step.-traceProgram :: State -> [State]+traceProgram :: State -> Trace traceProgram = iterate step -- | Trace a program until it either hits four nops or all 0s.-stepProgram :: State -> [State]+stepProgram :: State -> Trace stepProgram = takeWhile (not . done) . traceProgram where done state = i state == 0x39ce7 || i state == 0 @@ -50,12 +71,12 @@ runNativeProgram start program = eval $ setProgram 0 program start -- | Estimates the execution time of a program trace.-countTime :: [State] -> Double+countTime :: Trace -> Double countTime = runningTime . map (fromBits . i) -- | Checks that the program trace terminated in at most n steps, -- returning Nothing otherwise.-throttle :: Int -> [State] -> Either [State] [State]+throttle :: Int -> Trace -> Either Trace Trace throttle n state | null res = Right [startState] | length res == n = Left res | otherwise = Right res@@ -65,6 +86,11 @@ endWord :: Opcode -> Bool endWord = (`elem` [Ret, Exec, Jmp, Call, Unext, Next, If, MinusIf]) +-- | Extends the given trace by a single execution step. The trace+-- cannot be empty.+run :: Opcode -> [State] -> [State]+run op trace = trace ++ [execute op $ last trace]+ -- | Executes an opcode on the given state. execute :: Opcode -> State -> State execute op state@State {a, b, p, r, s, t, memory} = case op of@@ -115,3 +141,4 @@ If -> if t /= 0 then state {p = addr} else state MinusIf -> if t `testBit` pred (bitSize (0 :: F18Word)) then state else state {p = addr} _ -> error "Non-jump instruction given a jump address!"+
src/Language/ArrayForth/State.hs view
@@ -73,6 +73,11 @@ -- | Loads the given program into memory at the given starting -- position. setProgram :: F18Word -> NativeProgram -> State -> State-setProgram start program state@State {memory} = state' {i = toBits $ next state'}- where state' = state {memory = memory // prog}- prog = zip [toMem start..] (fromIntegral . toBits <$> program)+setProgram start program state = state' { i = toBits $ next state' }+ where state' = loadMemory start (fromIntegral . toBits <$> program) state++-- | Load the given memory words into the state starting at the given+-- address.+loadMemory :: F18Word -> [F18Word] -> State -> State+loadMemory start values state@State {memory} =+ state { memory = memory // zip [toMem start..] (fromIntegral <$> values) }
src/Language/ArrayForth/Synthesis.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module Language.ArrayForth.Synthesis where@@ -8,8 +9,10 @@ import Control.Arrow (first) import Control.Monad.Random (Random, random, randomR) +import Data.Function (on) import Data.Functor ((<$>))-import Data.List (genericLength, (\\))+import Data.List (elemIndices, genericLength, (\\))+import Data.Monoid (Monoid (..), (<>)) import Language.ArrayForth.Distance import Language.ArrayForth.Interpreter@@ -22,20 +25,49 @@ uniform) import Language.Synthesis.Mutations hiding (mix) import qualified Language.Synthesis.Mutations as M+import Language.Synthesis.Synthesis (Score (..)) +import Text.Printf++-- | A score type that contains a correctness value and a performance+-- value.+data DefaultScore = DefaultScore Double Double deriving (Ord, Eq)++instance Score DefaultScore where+ toScore (DefaultScore correctness performance) = correctness + 0.1 * performance++instance Show DefaultScore where show (DefaultScore a b) = printf "<%.2f, %.2f>" a b++instance Monoid DefaultScore where+ mempty = DefaultScore 0 0+ DefaultScore c₁ p₁ `mappend` DefaultScore c₂ p₂ = DefaultScore (c₁ + c₂) (p₁ + p₂)++-- | Creates an evaluation function from a spec, a set of inputs and a+-- function for comparing program traces.+trace :: Monoid score => Program -> [State] -> (Trace -> Trace -> score) -> Program -> score+trace spec inputs score program = mconcat $ zipWith score specs throttled+ where specs = stepProgram . load spec <$> inputs+ results = stepProgram . load program <$> inputs+ throttled = zipWith go specs results+ where go spec trace = either id id $ throttle (length spec) trace++-- | Using a given correctness measure, produce a score also+-- containing performance.+withPerformance :: Score s => (Trace -> Trace -> s) -> (Trace -> Trace -> DefaultScore)+withPerformance score spec result = DefaultScore (toScore $ score spec res) performance+ where res = either id id $ throttle (length spec) result+ performance = case throttle (length spec) result of+ Right res -> (countTime spec - countTime res) / 10+ Left res -> countTime spec - countTime res - 1e10+ -- | Given a specification program and some inputs, evaluate a program--- against the specification for both performance and correctness.-evaluate :: Program -> [State] -> Distance -> Program -> Double-evaluate spec inputs score program =- 0.1 * (10 * sum correctness + sum performance / genericLength inputs)- where specs = stepProgram . load spec <$> inputs- progs = stepProgram . load program <$> inputs- cases = zip3 (last <$> specs) (length <$> specs) (countTime <$> specs)- (correctness, performance) = unzip $ zipWith test progs cases- test prog (output, steps, time) = case throttle steps prog of- Right res -> calc res- Left res -> let (a, b) = calc res in (a - 1e10, b - 1e10)- where calc res = (-score output (last res), time - countTime res)+-- against the specification for both performance and+-- correctness. Normalize the score based on the number of test cases.+evaluate :: Program -> [State] -> (State -> State -> Distance) -> Program -> DefaultScore+evaluate spec inputs distance =+ normalize . trace spec inputs (withPerformance (distance `on` last))+ where normalize (DefaultScore c p) = DefaultScore (c / len) (p / len)+ len = genericLength inputs -- I need this so that I can get a distribution over Forth words. instance Random F18Word where@@ -51,12 +83,26 @@ defaultOps :: Distr Instruction defaultOps = mix [(constants, 1.0), (uniform [Unused], 1.0), (uniform instrs, genericLength instrs)]- where instrs = map Opcode $ filter (not . isJump) opcodes \\ [Unext, Exec, Ret]- constants = let Distr {sample, logProbability} = randInt (0, maxBound)+ where instrs = map Opcode $ filter (not . isJump) opcodes \\ [Unext, Nop]+ constants = let Distr {..} = randInt (0, maxBound) logProb (Number n) = logProbability n logProb _ = negativeInfinity in Distr { sample = Number <$> sample , logProbability = logProb }++pairs :: [(Instruction, Instruction)]+pairs = map (\ (a, b) -> (Opcode a, Opcode b))+ [ (SetA, ReadA)+ , (Push, Pop)+ , (Over, Drop) ]++removePairs :: Distr Instruction -> Mutation Program+removePairs instrDistr program =+ mix [(mutateInstructionsAt instrDistr is program, 1.0) | is <- findPairs program]+ where findPairs program = do (a, b) <- pairs+ indexA <- elemIndices a program+ indexB <- elemIndices b program+ return [indexA, indexB] -- | The default mutations to try. For now, this will either change an -- instruction or swap two instructions in the program, with equal
src/Main.hs view
@@ -2,22 +2,27 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Arrow ((&&&), second) import Control.Monad.Random (evalRandIO) +import Data.Bits (complement)+import Data.Function (on) import Data.List (find)+import Data.Monoid (Sum (..)) import Options.Applicative -import Language.ArrayForth.Distance (Distance, registers)+import Language.ArrayForth.Distance (Distance, matching, registers) import Language.ArrayForth.Interpreter (eval) import Language.ArrayForth.Parse () import Language.ArrayForth.Program (Program, load, readProgram)+import qualified Language.ArrayForth.Stack as S import Language.ArrayForth.State (State (..), startState)-import Language.ArrayForth.Synthesis (defaultMutations, defaultOps,- evaluate)+import Language.ArrayForth.Synthesis (DefaultScore (..), defaultMutations, defaultOps,+ evaluate, trace, withPerformance) import qualified Language.Synthesis.Distribution as Distr-import Language.Synthesis.Synthesis (Problem (..), runningBest,+import Language.Synthesis.Synthesis (Problem (..), Score (..), runningBest, synthesizeMhList) data Options = Options { verbose :: Bool }@@ -33,30 +38,57 @@ main :: IO () main = do Options { verbose } <- execParser go if verbose then verbosely else run- where go = info (helper <*> options) (fullDesc <>- progDesc "Synthesize arrayForth programs using MCMC." <>- header "mcmc-demo - simple synthesis with MCMC")+ where go = info (helper <*> options)+ (fullDesc <>+ progDesc "Synthesize arrayForth programs using MCMC." <>+ header "mcmc-demo - simple synthesis with MCMC") -good :: (Program, Double) -> Bool-good (_, val) = val >= 0.5+good :: Score s => (Program, s) -> Bool+good (_, val) = toScore val >= 0.5 verbosely :: IO () verbosely = do ls <- evalRandIO (synthesizeMhList inclusiveOr)- mapM_ print . zip ls . takeWhile (not . good) $ runningBest ls+ mapM_ (print . second toScore . fst) . zip ls . takeWhile (not . good) $ runningBest ls run :: IO () run = evalRandIO (synthesizeMhList inclusiveOr) >>= print . find good . runningBest -test :: Distance -> String -> String -> State -> Double+test :: (State -> State -> t) -> String -> String -> State -> t test distance p₁ p₂ input = let r₁ = eval $ load (read p₁) input r₂ = eval $ load (read p₂) input in distance r₁ r₂ -inclusiveOr :: Problem Program-inclusiveOr = Problem { score = evaluate program cases distance- , prior = Distr.constant program+orSpec :: Program+orSpec = "over over or a! and a or"++cases :: [State]+cases = [startState {t = 0, s = 123}, startState {t = maxBound, s = 123},+ startState {t = 1, s = 123}, startState {t = maxBound - 1, s = 123},+ startState {t = 37, s = 123}, startState {t = 52, s = 123}]++inclusiveOr :: Problem Program DefaultScore+inclusiveOr = Problem { score = evaluate orSpec cases distance+ , prior = Distr.constant orSpec , jump = defaultMutations }- where program = read "over over or a! and a or"- cases = [startState {t = 0, s = 123}, startState {t = maxBound, s = 123},- startState {t = 1, s = 123}, startState {t = maxBound - 1, s = 123}]- distance = registers [t]+ where complemented σ₁ σ₂@State {t = t₂} =+ Sum . negate . getSum . registers [t] σ₁ $ σ₂ {t = complement t₂}+ distance = registers [t] <> complemented++traceOr :: Problem Program DefaultScore+traceOr = Problem { score = trace orSpec cases $ withPerformance sc+ , prior = Distr.constant orSpec+ , jump = defaultMutations }+ where sc = matching (s &&& t) <> (registers [t] `on` last)++-- bitwiseSwap :: Problem Program DefaultScore+-- bitwiseSwap = Problem { score = evaluate program cases distance+-- , prior = Distr.constant program+-- , jump = defaultMutations }+-- where program = "a! over over . a - and . push a and . pop over over . or push and . pop or . ."+-- cases = [ startState {t = 46, s = 18, dataStack = st 43}+-- , startState {t = 232, s = 123, dataStack = st 0}+-- , startState {t = 2352, s = 123, dataStack = st 1}+-- , startState {t = maxBound - 5, s = 123, dataStack = st 13}+-- ]+-- distance = registers [t]+-- st = S.push S.empty
src/Run.hs view
@@ -28,7 +28,7 @@ where go loc state = do inp <- putStr "λ>" >> hFlush stdout >> getLine case inp of- [':'] -> putStrLn "Please specify a command!" >> go loc state+ ":" -> putStrLn "Please specify a command!" >> go loc state ':' : commands -> let command : args = words commands in run command args >>= uncurry go program -> execute $ readProgram program