diff --git a/array-forth.cabal b/array-forth.cabal --- a/array-forth.cabal +++ b/array-forth.cabal @@ -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 diff --git a/src/Chart.hs b/src/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Chart.hs @@ -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) diff --git a/src/Language/ArrayForth/Distance.hs b/src/Language/ArrayForth/Distance.hs --- a/src/Language/ArrayForth/Distance.hs +++ b/src/Language/ArrayForth/Distance.hs @@ -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₂) diff --git a/src/Language/ArrayForth/Interpreter.hs b/src/Language/ArrayForth/Interpreter.hs --- a/src/Language/ArrayForth/Interpreter.hs +++ b/src/Language/ArrayForth/Interpreter.hs @@ -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!" + diff --git a/src/Language/ArrayForth/State.hs b/src/Language/ArrayForth/State.hs --- a/src/Language/ArrayForth/State.hs +++ b/src/Language/ArrayForth/State.hs @@ -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) } diff --git a/src/Language/ArrayForth/Synthesis.hs b/src/Language/ArrayForth/Synthesis.hs --- a/src/Language/ArrayForth/Synthesis.hs +++ b/src/Language/ArrayForth/Synthesis.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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