Skip to content

Commit 466766c

Browse files
exaexaexaexa
committed
support a few different SOM shapes
1 parent 8b3011a commit 466766c

2 files changed

Lines changed: 137 additions & 32 deletions

File tree

‎app/Main.hs‎

Lines changed: 71 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -238,20 +238,8 @@ trainStartSOM opts =
238238

239239
runGen :: GenOpts -> IO (A.Matrix Float, [[Float]], A.Matrix Float)
240240
runGen opts = do
241-
let somn = genX opts * genY opts
242-
coords = (`divMod` genY opts)
243-
somsqdist i j =
244-
let (a, b) = coords i
245-
(c, d) = coords j
246-
in (a - c) * (a - c) + (b - d) * (b - d)
247-
proj =
248-
map
249-
((\(a, b) -> [fromIntegral a, fromIntegral b]) . coords)
250-
[0 .. somn - 1]
251-
topo =
252-
A.fromFunction
253-
(Z :. somn :. somn)
254-
(\(Z :. i :. j) -> fromIntegral $ somsqdist i j)
241+
let (proj, topo) = genTopo (genShape opts)
242+
(Z :. somn :. _) = A.arrayShape topo
255243
centroids <-
256244
A.fromList (Z :. somn :. genDim opts)
257245
. fst
@@ -270,3 +258,72 @@ outputSSCStats opts sums sqsums counts = do
270258
J.encodeFile o $ A.toList counts
271259
withJust (statsVariancesOut opts) $ \o -> do
272260
J.encodeFile o . matrixArray $ somVariancesLL sums sqsums counts
261+
262+
{-
263+
- Topology generators
264+
-}
265+
anglesAround :: (Floating a2, Integral a1) => a1 -> [a2]
266+
anglesAround n = [2 * pi * fromIntegral i / fromIntegral n | i <- [0 .. pred n]]
267+
268+
sqAngleDist :: Floating a => a -> a -> a
269+
sqAngleDist a b = 1 - sin a * sin b - cos a * cos b
270+
271+
squared :: Num a => a -> a
272+
squared a = a * a
273+
274+
rng :: (Integral a, Num b) => a -> [b]
275+
rng e = fromIntegral <$> [0 .. pred e]
276+
277+
rng1 :: (Integral a, Num b) => a -> [b]
278+
rng1 e = fromIntegral <$> [1 .. pred e]
279+
280+
genTopo :: SomShape -> ([[Float]], A.Matrix Float)
281+
genTopo (SomRectangle gx gy) = (proj, topo)
282+
where
283+
somn = gx * gy
284+
coords = (`divMod` gy)
285+
somsqdist i j =
286+
let (a, b) = coords i
287+
(c, d) = coords j
288+
in squared (a - c) + squared (b - d)
289+
proj =
290+
map
291+
((\(a, b) -> [fromIntegral a, fromIntegral b]) . coords)
292+
[0 .. somn - 1]
293+
topo =
294+
A.fromFunction
295+
(Z :. somn :. somn)
296+
(\(Z :. i :. j) -> fromIntegral $ somsqdist i j)
297+
genTopo (SomHex hx hy hz) = (proj, arrayMatrix sqdists)
298+
where
299+
off1 = 0.5
300+
off2 = sqrt 3 / 2
301+
proj =
302+
[[x - off1 * y, off2 * y] | x <- rng hx, y <- rng hy]
303+
++ [[x - off1 * z, -off2 * z] | x <- rng hx, z <- rng1 hz]
304+
++ [[-off1 * (y + z), off2 * (y - z)] | y <- rng1 hy, z <- rng1 hz]
305+
sqdists = [map (sum . map squared . zipWith (-) a0) proj | a0 <- proj]
306+
genTopo (SomTorus tx ty) = (proj, arrayMatrix sqdists)
307+
where
308+
proj = [[x, y] | x <- rng tx, y <- rng ty]
309+
angles = [(a, b) | a <- anglesAround tx, b <- anglesAround ty]
310+
sqdists = do
311+
(a0, b0) <- angles
312+
pure $ do
313+
(a, b) <- angles
314+
pure
315+
$ fromIntegral tx * sqAngleDist a a0
316+
+ fromIntegral ty * sqAngleDist b b0
317+
genTopo (SomCircle clen cwid) = (proj, arrayMatrix sqdists)
318+
where
319+
anglepos =
320+
[(a, fromIntegral x) | a <- anglesAround clen, x <- [0 .. pred cwid]]
321+
proj = do
322+
(a, x) <- anglepos
323+
let r = x + fromIntegral clen / (2 * pi)
324+
pure [cos a * r, sin a * r]
325+
sqdists = do
326+
(a0, x0) <- anglepos
327+
pure $ do
328+
(a, x) <- anglepos
329+
pure $ fromIntegral clen * sqAngleDist a a0 + squared (x - x0)

‎app/Opts.hs‎

Lines changed: 66 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -54,9 +54,72 @@ topoout =
5454
<> metavar "TOPOLOGY"
5555
<> help "write the SOM topology into this file"
5656

57+
data SomShape
58+
= SomRectangle Int Int
59+
| SomHex Int Int Int
60+
| SomTorus Int Int
61+
| SomCircle Int Int
62+
deriving (Show)
63+
64+
somshape :: Parser SomShape
65+
somshape =
66+
asum
67+
[ SomRectangle
68+
<$> (option auto
69+
$ long "grid-x"
70+
<> short 'x'
71+
<> metavar "X"
72+
<> help "rectangular grid dimension 1"
73+
<> value 10
74+
<> showDefault)
75+
<*> (option auto
76+
$ long "grid-y"
77+
<> short 'y'
78+
<> metavar "Y"
79+
<> help "rectangular grid dimension 2"
80+
<> value 10
81+
<> showDefault)
82+
, SomHex
83+
<$> (option auto
84+
$ long "hex-x"
85+
<> metavar "X"
86+
<> help "hexagonal grid dimension 1")
87+
<*> (option auto
88+
$ long "hex-y"
89+
<> metavar "Y"
90+
<> help "hexagonal grid dimension 2")
91+
<*> (option auto
92+
$ long "hex-z"
93+
<> metavar "Z"
94+
<> help "hexagonal grid dimension 3"
95+
<> value 1
96+
<> showDefault)
97+
, SomTorus
98+
<$> (option auto
99+
$ long "torus-x"
100+
<> metavar "X"
101+
<> help "toroidal grid dimension 1")
102+
<*> (option auto
103+
$ long "torus-y"
104+
<> metavar "Y"
105+
<> help "toroidal grid dimension 2"
106+
<> value 1
107+
<> showDefault)
108+
, SomCircle
109+
<$> (option auto
110+
$ long "circle-length"
111+
<> metavar "X"
112+
<> help "circular grid circumference")
113+
<*> (option auto
114+
$ long "circle-width"
115+
<> metavar "Y"
116+
<> help "circular grid strip width"
117+
<> value 1
118+
<> showDefault)
119+
]
120+
57121
data GenOpts = GenOpts
58-
{ genX :: Int
59-
, genY :: Int
122+
{ genShape :: SomShape
60123
, genDim :: Int
61124
, genSeed :: (Maybe Int)
62125
} deriving (Show)
@@ -68,22 +131,7 @@ dimopt =
68131

69132
genopts :: Parser GenOpts
70133
genopts = do
71-
genX <-
72-
option auto
73-
$ long "som-x"
74-
<> short 'x'
75-
<> metavar "X"
76-
<> help "grid dimension 1"
77-
<> value 10
78-
<> showDefault
79-
genY <-
80-
option auto
81-
$ long "som-y"
82-
<> short 'y'
83-
<> metavar "Y"
84-
<> help "grid dimension 2"
85-
<> value 10
86-
<> showDefault
134+
genShape <- somshape
87135
genDim <- dimopt
88136
genSeed <-
89137
optional . option auto

0 commit comments

Comments
 (0)