Unsupervised.hs

#!/usr/bin/env stack
-- stack script --resolver lts-12.0
--  --package diagrams
--  --package diagrams-lib
--  --package diagrams-cairo
--  --package random

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE ViewPatterns               #-}

-- Run with:
--  ./Unsupervised.hs -w 500 -o a.gif

import Control.Monad
import Data.Typeable
import Diagrams.Backend.Cairo.CmdLine
import Diagrams.Prelude
import System.Random

main :: IO ()
main = mainWith d >> putStrLn "Done!"


d :: IO [(Diagram B, Int)]
d = do
  let points  = 30
      n       = 2 * 2 * points
      steps   = 50

  xs :: [Double] <- replicateM n (randomRIO (-1, 1))
  ys :: [Double] <- replicateM n (randomRIO (-1, 1))

  let startingPoints = zipWith mkP2 xs ys

  xs' :: [Double] <- replicateM (n `div` 2) (randomRIO (-1, 1))
  ys' :: [Double] <- replicateM (n `div` 2) (randomRIO (-1, 1))

  ys'' :: [Double] <- flip mapM xs' (\x -> randomRIO (-1, x) >>= return)
  xs'' :: [Double] <- flip mapM ys' (\y -> randomRIO (-1, y) >>= return)

  let upperPoints  = zipWith mkP2 xs' ys''
      lowerPoints  = zipWith mkP2 xs'' ys'
      endingPoints = upperPoints ++ lowerPoints
  
  let allPoints = map (\s -> zipWith (\a b -> (1-(s/steps))*a + (s/steps)*b) startingPoints endingPoints) 
                      (map fromIntegral [1..steps-1])

      allPoints' = map (\p -> (p, black, black)) allPoints
      finalSet   = allPoints' ++ map (\p -> (p, blue, red)) (replicate 20 (last allPoints))

  return $ zipWith (\(d', c1, c2) k -> (dd d' c1 c2, 1)) finalSet [1..]


-- | "xs" and "ys" should be a list of 40 points, the first 20 of which
--   are red, and the second 20 are blue.
dd :: [Point V2 Double] 
   -> Colour Double
   -> Colour Double
   -> Diagram B
dd pts c1 c2 = dd <> square 2.04 # bg lightgray
  where
    dd  =  position (zip (take pointCounts pts) blues) 
        <> position (zip (drop pointCounts pts) reds)
        <> ((-1) ^& (-1)) ~~ (1 ^& 1)

    blues  = replicate pointCounts $ circle 0.02 # fc c1 # lw 0
    reds   = replicate pointCounts $ circle 0.02 # fc c2 # lw 0

    pointCounts = length pts `div` 2