module Language.ArrayForth.Synthesis where
import Control.Arrow (first)
import Control.Monad.Random (Random, random, randomR)
import Data.Function (on)
import Data.Functor ((<$>))
import Data.List (elemIndices, genericLength, (\\))
import Data.Monoid (Monoid (..), (<>))
import Language.ArrayForth.Distance
import Language.ArrayForth.Interpreter
import Language.ArrayForth.Opcode
import Language.ArrayForth.Program
import Language.ArrayForth.State
import Language.Synthesis.Distribution (Distr (..), mix,
negativeInfinity, randInt,
uniform)
import Language.Synthesis.Mutations hiding (mix)
import qualified Language.Synthesis.Mutations as M
import Language.Synthesis.Synthesis (Score (..))
import Text.Printf
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₂)
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
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
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
instance Random F18Word where
randomR (start, end) gen =
first fromInteger $ randomR (fromIntegral start, fromIntegral end) gen
random = randomR (0, maxBound)
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, 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]
defaultMutations :: Mutation Program
defaultMutations = M.mix [(mutateInstruction defaultOps, 1), (swapInstructions, 1)]