-{-# LANGUAGE TypeOperators, TemplateHaskell, TypeFamilies,
- ScopedTypeVariables, RecordWildCards, FlexibleContexts #-}
+{-# LANGUAGE TypeOperators, TemplateHaskell, TypeFamilies, ScopedTypeVariables #-}
module HigherOrderCPU where
type Word = SizedInt D16
type Index = RangedWord
-const :: a -> a -> a
const a b = a
-fu :: ( PositiveT p, NaturalT n, (p :>: n) ~ True) =>
- (a -> a -> a)
- -> Vector p a
- -> (Index n, Index n)
- -> a
- -> (a, a)
-fu op inputs (addr1, addr2) out =
- (out', out)
+fu op inputs (addr1, addr2) = regIn
where
- in1 = inputs!addr1
- in2 = inputs!addr2
- out' = op in1 in2
+ in1 = inputs!addr1
+ in2 = inputs!addr2
+ regIn = op in1 in2
type CpuState = State (Vector D4 Word)
{-# ANN cpu TopEntity #-}
{-# ANN cpu (InitState 'cpuState) #-}
-cpu ::
- Word
- -> Vector D4 (Index D6, Index D6)
- -> CpuState
+cpu :: CpuState -> Word -> Vector D4 (Index D6, Index D6)
-> (CpuState, Word)
-cpu input addrs (State fuss) =
- (State fuss', out)
+cpu (State fuss) input addrs = (State fuss', out)
where
- fures = (fu const inputs (addrs!(0 :: Index D3)) (fuss!(0 :: Index D3))) +> (
- (fu (+) inputs (addrs!(1 :: Index D3)) (fuss!(1 :: Index D3))) +> (
- (fu (-) inputs (addrs!(2 :: Index D3)) (fuss!(2 :: Index D3))) +> ( singleton
- (fu (*) inputs (addrs!(3 :: Index D3)) (fuss!(3 :: Index D3))))))
- (fuss', outputs) = unzip fures
- inputs = 0 +> (1 +> (input +> outputs))
- out = head outputs
+ fuss' = (fu const inputs (addrs!(0 :: Index D3))) +> (
+ (fu (+) inputs (addrs!(1 :: Index D3))) +> (
+ (fu (-) inputs (addrs!(2 :: Index D3))) +> (
+ (fu (*) inputs (addrs!(3 :: Index D3))) +> empty)))
+ inputs = 0 +> (1 +> (input +> fuss))
+ out = head fuss
cpuState :: Vector D4 Word
cpuState = copy 0
\ No newline at end of file