crossover.md

First, let's roll our own state monad. We'll treat assignments just as sequences of individuals.

{-# LANGUAGE TupleSections #-}

import Data.Bifunctor (first)
import Control.Applicative (liftA2)

type E = Int

type G = [E]

dom :: [E]
dom = [1..10]

newtype S a = S { runS :: G -> (a,G)}

instance Functor S where
    fmap f m = S $ \g -> first f (runS m g)
    
instance Applicative S where
    pure a = S (a,)
    m <*> n = S $ \g ->
        let (f,g') = runS m g
            (x,g'') = runS n g'
        in (f x,g'')
        
newtype SS a = SS { runSS :: G -> [(a,G)]}

instance Functor SS where
    fmap f m = SS $ \g -> first f <$> runSS m g
    
instance Applicative SS where
    pure a = SS $ (:[]) <$> (a,)
    m <*> n = undefined

instance Monad SS where
    return = pure
    m >>= k = SS $ \g ->
        let pairs = runSS m g
        in concat [(runSS $ k x) g' | (x,g') <- pairs ]
 
intro :: S E -> S E
intro m = S $ \g ->
    let (x,g') = runS m g
    in (x,x:g')

pro :: S E
pro = S $ \(x:g) -> (x,g)

test1 = ($ []) $ runS $ liftA2 (&&) (pure odd <*> (intro . pure $ 1)) (pure even <*> intro pro)
test1

test2 = ($ []) $ runS $ liftA2 (&&) (pure odd <*> (intro pro)) (pure even <*> intro (pure 1))
test2

Let's roll our own continuation monad:

newtype K b a = K { (>>-) :: (a -> b) -> b}

instance Functor (K b) where
    fmap f m = K $ \k -> m >>- (k . f)
    
instance Applicative (K b) where
    pure x = K $ \k -> k x
    m <*> n = K $ \k -> m >>- \f -> n >>- \x -> k (f x)
    
liftS :: S a -> SS a
liftS m = SS $ \g -> [runS m g]

lower :: K (SS a) (S a) -> SS a
lower m = (>>-) m liftS

anEvenInt :: SS E
anEvenInt = SS $ \g -> [(n,g)|n <- dom, even n]

Let's see how maximally polymorphic liftS and lower allow a violation of crossover.

"One is less than its successor"

($ []) $ runS $ (liftA2 (<)) (intro $ pure 1) ((pure succ) <*> pro)

($ []) $ runS $ (liftA2 (<)) ((pure succ) <*> pro) (intro $ pure 1)

obj = pure pure <*> (K $ (>>=) $ (liftS (intro $ pure 1)))

"A successor to it is greater than 1"

($ []) $ runSS $ lower $ (liftA2 $ liftA2 (>)) (pure $ ((pure succ) <*> pro)) obj