Synthesis.hs

{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeSynonymInstances #-}
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

-- | 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. 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
  randomR (start, end) gen =
    first fromInteger $ randomR (fromIntegral start, fromIntegral end) gen
  random = randomR (0, maxBound)

-- | The default distribution of instructions. For now, we do not
-- support any sort of jumps. All the other possible instructions
-- along with constant numbers and unused slots are equally
-- likely. The numeric value of constants is currently a uniform
-- distribution over 18-bit words.
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]

-- | The default mutations to try. For now, this will either change an
-- instruction or swap two instructions in the program, with equal
-- probability.
defaultMutations :: Mutation Program
defaultMutations = M.mix [(mutateInstruction defaultOps, 1), (swapInstructions, 1)]