@@ -0,0 +1,174 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE StandaloneDeriving #-}
11+{-|
12+Module : Grenade.Layers.Concat
13+Description : Concatenation layer
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+
18+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.
19+-}
20+module Grenade.Recurrent.Layers.ConcatRecurrent (
21+ ConcatRecurrent (..)
22+ ) where
23+
24+import Data.Serialize
25+
26+import Data.Singletons
27+import GHC.TypeLits
28+
29+import Grenade.Core
30+import Grenade.Recurrent.Core
31+
32+import Numeric.LinearAlgebra.Static ( (#), split, R )
33+
34+-- | A Concatentating Layer.
35+--
36+-- This layer shares it's input state between two sublayers, and concatenates their output.
37+--
38+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.
39+--
40+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.
41+--
42+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.
43+-- Any 2 1D vectors can also become a longer 1D Vector.
44+--
45+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
46+-- and Crop layers to ensure this is the case.
47+data ConcatRecurrent :: Shape -> * -> Shape -> * -> * where
48+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)
49+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)
50+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)
51+
52+-- instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (p y)) where
53+-- show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y
54+-- show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y
55+-- show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y
56+
57+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where
58+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)
59+ runUpdate lr (ConcatRecLeft x y) (x', y')
60+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')
61+ createRandom
62+ = ConcatRecLeft <$> createRandom <*> createRandom
63+
64+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where
65+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)
66+ runUpdate lr (ConcatRecRight x y) (x', y')
67+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')
68+ createRandom
69+ = ConcatRecRight <$> createRandom <*> createRandom
70+
71+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where
72+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)
73+ runUpdate lr (ConcatRecBoth x y) (x', y')
74+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')
75+ createRandom
76+ = ConcatRecBoth <$> createRandom <*> createRandom
77+
78+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where
79+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x
80+
81+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where
82+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y
83+
84+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where
85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]
86+
87+instance ( SingI i
88+ , Layer x i ('D1 m)
89+ , RecurrentLayer y i ('D1 n)
90+ , KnownNat o
91+ , KnownNat m
92+ , KnownNat n
93+ , o ~ (m + n)
94+ , n ~ (o - m)
95+ , (m <=? o) ~ 'True
96+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where
97+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))
98+
99+ runRecurrentForwards (ConcatRecRight x y) s input =
100+ let (xT, xOut :: S ('D1 m)) = runForwards x input
101+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input
102+ in case (xOut, yOut) of
103+ (S1D xOut', S1D yOut') ->
104+ ((xT, yT), side, S1D (xOut' # yOut'))
105+
106+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =
107+ let (ox :: R m , oy :: R n) = split o
108+ (x', xB :: S i) = runBackwards x xTape (S1D ox)
109+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)
110+ in ((x', y'), side, xB + yB)
111+
112+instance ( SingI i
113+ , RecurrentLayer x i ('D1 m)
114+ , Layer y i ('D1 n)
115+ , KnownNat o
116+ , KnownNat m
117+ , KnownNat n
118+ , o ~ (m + n)
119+ , n ~ (o - m)
120+ , (m <=? o) ~ 'True
121+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where
122+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))
123+
124+ runRecurrentForwards (ConcatRecLeft x y) s input =
125+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input
126+ (yT, yOut :: S ('D1 n)) = runForwards y input
127+ in case (xOut, yOut) of
128+ (S1D xOut', S1D yOut') ->
129+ ((xT, yT), side, S1D (xOut' # yOut'))
130+
131+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =
132+ let (ox :: R m , oy :: R n) = split o
133+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)
134+ (y', yB :: S i) = runBackwards y yTape (S1D oy)
135+ in ((x', y'), side, xB + yB)
136+
137+instance ( SingI i
138+ , RecurrentLayer x i ('D1 m)
139+ , RecurrentLayer y i ('D1 n)
140+ , Fractional (RecurrentShape x)
141+ , Fractional (RecurrentShape y)
142+ , KnownNat o
143+ , KnownNat m
144+ , KnownNat n
145+ , o ~ (m + n)
146+ , n ~ (o - m)
147+ , (m <=? o) ~ 'True
148+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where
149+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))
150+
151+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =
152+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input
153+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input
154+ in case (xOut, yOut) of
155+ (S1D xOut', S1D yOut') ->
156+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))
157+
158+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =
159+ let (ox :: R m , oy :: R n) = split o
160+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)
161+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)
162+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)
163+
164+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where
165+ put (ConcatRecRight a b) = put a *> put b
166+ get = ConcatRecRight <$> get <*> get
167+
168+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where
169+ put (ConcatRecBoth a b) = put a *> put b
170+ get = ConcatRecBoth <$> get <*> get
171+
172+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where
173+ put (ConcatRecLeft a b) = put a *> put b
174+ get = ConcatRecLeft <$> get <*> get