@@ -0,0 +1,125 @@
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.Core.Network
13+Description : Core definition a simple neural etwork
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+-}
18+module Grenade.Layers.Concat (
19+ Concat (..)
20+ ) where
21+
22+import Data.Singletons
23+import GHC.TypeLits
24+
25+import Grenade.Core
26+
27+import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )
28+
29+-- | A Concatentating Layer.
30+--
31+-- This layer shares it's input state between two sublayers, and concatenates their output.
32+--
33+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.
34+--
35+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.
36+--
37+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.
38+-- Any 2 1D vectors can also become a longer 1D Vector.
39+--
40+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
41+-- and Crop layers to ensure this is the case.
42+data Concat :: Shape -> * -> Shape -> * -> * where
43+ Concat :: x -> y -> Concat m x n y
44+
45+instance (Show x, Show y) => Show (Concat m x n y) where
46+ show (Concat x y) = "Concat\n" ++ show x ++ "\n" ++ show y
47+
48+-- | Run two layers in parallel, combining their outputs.
49+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Concat m x n y) where
50+ type Gradient (Concat m x n y) = (Gradient x, Gradient y)
51+ runUpdate lr (Concat x y) (x', y') = Concat (runUpdate lr x x') (runUpdate lr y y')
52+ createRandom = Concat <$> createRandom <*> createRandom
53+
54+instance ( SingI i
55+ , Layer x i ('D1 o)
56+ , Layer y i ('D1 o)
57+ ) => Layer (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) where
58+ type Tape (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) = (Tape x i ('D1 o), Tape y i ('D1 o))
59+
60+ runForwards (Concat x y) input =
61+ let (xT, xOut :: S ('D1 o)) = runForwards x input
62+ (yT, yOut :: S ('D1 o)) = runForwards y input
63+ in case (xOut, yOut) of
64+ (S1D xOut', S1D yOut') ->
65+ ((xT, yT), S2D (row xOut' === row yOut'))
66+
67+ runBackwards (Concat x y) (xTape, yTape) (S2D o) =
68+ let (ox, oy) = splitRows o
69+ (x', xB :: S i) = runBackwards x xTape (S1D $ unrow ox)
70+ (y', yB :: S i) = runBackwards y yTape (S1D $ unrow oy)
71+ in ((x', y'), xB + yB)
72+
73+instance ( SingI i
74+ , Layer x i ('D1 m)
75+ , Layer y i ('D1 n)
76+ , KnownNat o
77+ , KnownNat m
78+ , KnownNat n
79+ , o ~ (m + n)
80+ , n ~ (o - m)
81+ , (m <=? o) ~ 'True
82+ ) => Layer (Concat ('D1 m) x ('D1 n) y) i ('D1 o) where
83+ type Tape (Concat ('D1 m) x ('D1 n) y) i ('D1 o) = (Tape x i ('D1 m), Tape y i ('D1 n))
84+
85+ runForwards (Concat x y) input =
86+ let (xT, xOut :: S ('D1 m)) = runForwards x input
87+ (yT, yOut :: S ('D1 n)) = runForwards y input
88+ in case (xOut, yOut) of
89+ (S1D xOut', S1D yOut') ->
90+ ((xT, yT), S1D (xOut' # yOut'))
91+
92+ runBackwards (Concat x y) (xTape, yTape) (S1D o) =
93+ let (ox :: R m , oy :: R n) = split o
94+ (x', xB :: S i) = runBackwards x xTape (S1D ox)
95+ (y', yB :: S i) = runBackwards y yTape (S1D oy)
96+ in ((x', y'), xB + yB)
97+
98+-- | Concat 3D shapes, increasing the number of channels.
99+instance ( SingI i
100+ , Layer x i ('D3 rows cols m)
101+ , Layer y i ('D3 rows cols n)
102+ , KnownNat (rows * n)
103+ , KnownNat (rows * m)
104+ , KnownNat (rows * o)
105+ , KnownNat o
106+ , KnownNat m
107+ , KnownNat n
108+ , ((rows * m) + (rows * n)) ~ (rows * o)
109+ , ((rows * o) - (rows * m)) ~ (rows * n)
110+ , ((rows * m) <=? (rows * o)) ~ 'True
111+ ) => Layer (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) where
112+ type Tape (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) = (Tape x i ('D3 rows cols m), Tape y i ('D3 rows cols n))
113+
114+ runForwards (Concat x y) input =
115+ let (xT, xOut :: S ('D3 rows cols m)) = runForwards x input
116+ (yT, yOut :: S ('D3 rows cols n)) = runForwards y input
117+ in case (xOut, yOut) of
118+ (S3D xOut', S3D yOut') ->
119+ ((xT, yT), S3D (xOut' === yOut'))
120+
121+ runBackwards (Concat x y) (xTape, yTape) (S3D o) =
122+ let (ox, oy) = splitRows o
123+ (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))
124+ (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))
125+ in ((x', y'), xB + yB)