path: root/axis.hs

{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE StandaloneDeriving #-}
import FRP.Netwire hiding (when)
import Prelude hiding ((.), id, null, filter)
import Data.Time.Clock
import Control.Wire hiding (when)
import Control.Wire.Session
import Control.Monad
import qualified Graphics.UI.SDL as SDL
import AlsaSeq
import qualified Data.Set as Set
import qualified Graphics.UI.SDL.TTF as SDL.TTF
import Data.String
import Graphics.UI.SDL.Keysym as SDL.Keysym
import Graphics.UI.SDL.Primitives as SDL.Primitive
import Data.Int (Int16)
import qualified System.Exit as Exit
import Data.List (elemIndex, elemIndices, filter)
import GHC.Word
import Data.Bits

netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String
netwireIsCool =
    for 2.5 . pure "Once upon a time..." -->
    for 3   . pure "... games were completely imperative..." -->
    for 2   . pure "... but then..." -->
    for 10  . (pure "Netwire 5! " <> anim) -->
    netwireIsCool

  where
    anim =
        holdFor 0.5 . periodic 1 . pure "Hoo..." <|>
        pure "...ray!"

smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars

_USE_HEXAGONS = False
_COLORIZE_BY_CHANNEL = False

_AXIS_ROWS = 7 + 4
_AXIS_UNIQUE_COLS = 7
_AXIS_COLS_REPEAT = 2
_AXIS_TOP_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2)
_AXIS_BOTTOM_PITCH = 81 - (7 * _AXIS_ROWS) - 3

_KEY_COLOR = (SDL.Color 0 0 255)
_KEY_BG_COLOR = (SDL.Color 0 0 0)
_KEY_TEXT_COLOR = (SDL.Color 128 128 0)

_KEY_COLOR_PIXEL = colorToPixel _KEY_COLOR
_KEY_BG_COLOR_PIXEL = colorToPixel _KEY_BG_COLOR

{-
http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
 0 – black                      (#000000) 000000  0
 1 – blue                       (#0000AA) 000001  1
 2 – green                      (#00AA00) 000010  2
 3 – cyan                       (#00AAAA) 000011  3
 4 – red                        (#AA0000) 000100  4
 5 – magenta                    (#AA00AA) 000101  5
 6 – brown                      (#AA5500) 010100  20
 7 – white / light gray         (#AAAAAA) 000111  7
 8 – dark gray / bright black   (#555555) 111000  56
 9 – bright blue                (#5555FF) 111001  57
10 – bright green               (#55FF55) 111010  58
11 – bright cyan                (#55FFFF) 111011  59
12 – bright red                 (#FF5555) 111100  60
13 – bright magenta             (#FF55FF) 111101  61
14 – bright yellow              (#FFFF55) 111110  62
15 – bright white               (#FFFFFF) 111111  63
-}

_CGA = [(SDL.Color 0x00 0x00 0x00), (SDL.Color 0x00 0x00 0xAA), (SDL.Color 0x00 0xAA 0x00), (SDL.Color 0x00 0xAA 0xAA), (SDL.Color 0xAA 0x00 0x00), (SDL.Color 0xAA 0x00 0xAA), (SDL.Color 0xAA 0x55 0x00), (SDL.Color 0xAA 0xAA 0xAA), (SDL.Color 0x55 0x55 0x55), (SDL.Color 0x55 0x55 0xFF), (SDL.Color 0x55 0xFF 0x55), (SDL.Color 0x55 0xFF 0xFF), (SDL.Color 0xFF 0x55 0x55), (SDL.Color 0xFF 0x55 0xFF), (SDL.Color 0xFF 0xFF 0x55), (SDL.Color 0xFF 0xFF 0xFF)]

_drawHexircle f v x y s c =
  if _USE_HEXAGONS
  then _drawHexagonSDL f v x y s c
  else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c

drawHexircle  = _drawHexircle False
drawFilledHexircle = _drawHexircle True
colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b

drawKeys pitches videoSurface font axis_key_locations axis_key_size = do

  forM_ pitches $ \pitch -> do
    forM_ (elemIndices pitch pitchIndex) $ \idx -> do
      let (x, y) = axis_key_locations !! idx
      drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_COLOR_PIXEL
      centerText videoSurface x y font _KEY_TEXT_COLOR _KEY_COLOR (smartShowPitch pitch)

reallyEraseKeys = eraseKeys_ True
eraseKeys = eraseKeys_ False


smartDrawKeys really drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do

  let drawList  = map (\ (_, n) -> unPitch n) $ Set.toList drawSet
  let eraseList = map (\ (_, n) -> unPitch n) $ filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet

  eraseKeys_ really eraseList videoSurface font axis_key_locations axis_key_size

  forM_ (Set.toList drawSet) $ \ (c, n) -> do
    let pitch = unPitch n
    let chann = unChannel c
    let color = if _COLORIZE_BY_CHANNEL
                then _CGA !! (((fromIntegral chann) + 2) `mod` 16)
                else _KEY_COLOR
    Control.Monad.when(chann /= 9) $ -- TODO: do this elsewhere
      forM_ (elemIndices pitch pitchIndex) $ \idx -> do
        let (x, y) = axis_key_locations !! idx
        drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel color)
        drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_COLOR_PIXEL
        centerText videoSurface x y font _KEY_TEXT_COLOR color (smartShowPitch pitch)

eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size = do

  forM_ pitches $ \pitch -> do
    forM_ (elemIndices pitch pitchIndex) $ \idx -> do
      let (x, y) = axis_key_locations !! idx
      drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_BG_COLOR_PIXEL
      drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (if really then _KEY_BG_COLOR_PIXEL else _KEY_COLOR_PIXEL)
--    centerText videoSurface x y font _KEY_TEXT_COLOR _KEY_BG_COLOR (smartShowPitch pitch)

fi = fromIntegral
rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255))

main =
  withAlsaInit $ \h public private q publicAddr privateAddr -> do
  cmdlineAlsaConnect h public -- fail early if bad command lines

  SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do
  info <- SDL.getVideoInfo
  let width = SDL.videoInfoWidth info
      height = SDL.videoInfoHeight info
      warpMouse = do
        _ <- SDL.warpMouse (fromIntegral (width `div` 2)) (fromIntegral (height `div` 2))
        return ()
--screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen]
  screen <- SDL.setVideoMode width height 32 [SDL.SWSurface]

  _ <- SDL.TTF.init
  font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30
  videoSurface <- SDL.getVideoSurface
  videoClipRect <- SDL.getClipRect videoSurface
--_ <- SDL.showCursor False
--_ <- SDL.grabInput True
--warpMouse

--let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
  pixelFormat <- SDL.surfaceGetPixelFormat <$> SDL.createRGBSurfaceEndian [] 1 1 24
  -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?

  let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect

  let _ALL_PITCHES = [_AXIS_BOTTOM_PITCH .. _AXIS_TOP_PITCH]
  let allKeysOFF =             eraseKeys _ALL_PITCHES videoSurface font axis_key_locations axis_key_size
      allKeysReallyOFF = reallyEraseKeys _ALL_PITCHES videoSurface font axis_key_locations axis_key_size
  allKeysOFF

  putStrLn "Initialized."

  let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
  let loop midiKeysDown keysDown s w x = do
        keysDown' <- parseSDLEvents keysDown
        midiKeysDown' <- parseAlsa midiKeysDown
        (ds, s') <- stepSession s
        (ex, w') <- stepWire w ds (Right x)
        let x' = either (const "") id ex

--      Control.Monad.when (x /= x' && x' /= "") $ do
--        textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
--        return ()

        Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do
--        let chord = showChord midiKeysDown'
--        let chord = show $ pitchList midiKeysDown'
--        let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
--        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
          let ignoreThese = Set.intersection midiKeysDown' midiKeysDown
          let drawThese = Set.difference midiKeysDown' ignoreThese
          let eraseThese = Set.difference midiKeysDown ignoreThese

          smartDrawKeys False drawThese eraseThese videoSurface font axis_key_locations axis_key_size
          return ()

        Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF
        Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_c keysDown') allKeysReallyOFF

--      Control.Monad.when (keysDown' /= keysDown) $ do
--        let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
--        textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
--        textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
--          if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
--        return ()

--      Control.Monad.when(False) $ do
--
--        mouse <- SDL.getRelativeMouseState
--        let (x, y, button) = mouse
--        let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
--        textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text
--        Control.Monad.when (x /= 0 || y /= 0) warpMouse

        _ <- SDL.updateRect videoSurface videoClipRect -- draw it all!  probably a bad idea

        let framerate = 30
        let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
        SDL.delay (delay)
        Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $
          loop midiKeysDown' keysDown' s' w' x'

  loop Set.empty Set.empty clockSession_ netwireIsCool ""

zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls)

drawHexagonSDL = _drawHexagonSDL False
drawFilledHexagonSDL = _drawHexagonSDL True

_drawHexagonSDL filled videoSurface centerx centery radius pixel = do
  let r = fromIntegral radius
  let points = map (\(x, y) -> (centerx + x, centery + y)) $
               map (\(x, y) -> (round x, round y)) $
               map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) $ map fromIntegral [0 .. 5]
  (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel

centerText videoSurface x y font fgColor bgColor text = do
--fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing
  fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor
  fontClipRect <- SDL.getClipRect fontSurface
  let (SDL.Rect _ _ w h) = fontClipRect
  _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h))
  return ()

pitchIndex = concat $ map (\x -> unique) [0 .. _AXIS_COLS_REPEAT - 1]
  where
    toprow = map (\i -> if (i `mod` 2) == 0 then (_AXIS_TOP_PITCH + i `div` 2) else (_AXIS_TOP_PITCH - 3 + i `div` 2)) [0 .. _AXIS_UNIQUE_COLS - 1]
    colfrom top = map (+ top) $ map (* (-7)) [0 .. _AXIS_ROWS - 1]
    unique = concat $ map colfrom toprow

getKeyLocations (SDL.Rect offx offy totalw totalh) =
  let (key_height, key_width, xys) = getKeyLocationsAbs

      screenw = fromIntegral(totalw)
      screenh = fromIntegral(totalh)

      kb_rows = length xys
      kb_cols = length (head xys)

      -- there are 14 keys (13 steps) from the far left to the far right of the axis; if the radius is 1 each step is 1.5 horizontal, plus 2 halfs to fill to the edges
      -- thus the keyboard is radius * ((numkeys - 1) * 1.5 + 2)
      keyboard_width = (fromIntegral(kb_cols - 1) * 1.5 + 2) * key_width / 2
      keyboard_height = fromIntegral(kb_rows + 1) * key_height -- half of the keyboard is offset down one key

      fit_width = screenh / screenw > keyboard_height / keyboard_width
      scale = if fit_width
              then screenw / keyboard_width
              else screenh / keyboard_height

      kh = key_height * scale
      kw = key_width * scale

      centerx = (screenw - keyboard_width * scale) / 2
      centery = (screenh - keyboard_height * scale) / 2
    in
      (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys)

getKeyLocationsAbs =
  let kb_rows = (fromIntegral _AXIS_ROWS) :: Double
      kb_cols = _AXIS_COLS_REPEAT * (fromIntegral _AXIS_UNIQUE_COLS) :: Double
      -- the edges of the hexagon are equal in length to its "radius"
      -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next
      -- or else it is 2*sqrt(3) to move down

      kw = 1 :: Double
      kh = kw/2 * sqrt(3) -- hexagon ratio

      xys =
            map (\y -> map (\i -> (

                fromInteger(i) * kw * 3 / 4,

                y + kh / 2 * fromInteger(i `mod` 2) +

                  (if (fromInteger(i) >= _AXIS_UNIQUE_COLS) then kh * fromInteger((i+1) `mod` 2) else 0)

              )) [0 .. round(kb_cols) - 1]) $
            map (\i -> kh * fromIntegral(i))
                [0..round(kb_rows) - 1]
    in
      (kh, kw, xys)

-- clear a band the width of the videoClipRect and print the text within it, centered
textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
  let (SDL.Rect vx _ vw _) = videoClipRect
  _ <- SDL.fillRect videoSurface (Just (SDL.Rect 0 y vw h)) (SDL.Pixel 0)
  Control.Monad.when (text /= "") $ do
    fontSurface <- SDL.TTF.renderUTF8Blended font text (SDL.Color 0 255 0)
    fontClipRect <- SDL.getClipRect fontSurface
    let (SDL.Rect _ fy fw _) = fontClipRect
    _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect ((vw - fw) `div` 2) y vw h))
    return ()
  return ()

parseSDLEvents :: Set.Set SDL.SDLKey -> IO (Set.Set SDL.Keysym.SDLKey)
parseSDLEvents keysDown = do
  event <- SDL.pollEvent
  case event of
    SDL.NoEvent -> return keysDown
    SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown)
    SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown)
    _ -> parseSDLEvents keysDown

keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool
keyDown k s = Set.member k s

deriving instance Ord SDL.Keysym