yboardMouse :: IORef ProgramState -> KeyboardMouseCallback
keyboardMouse ps key Down _ _ = case key of
  Char 'q' -> exitSuccess
  Char 'f'-> toggleFlag ps Main.Fill
  Char 'r' -> get ps >>= \p -> ps $$! p & cameraShift
                               .~ defaultState ^. cameraShift
  Char 'x' -> onCoord cTheta (+ (pi / 200))
  Char 'y' -> onCoord cPhi (+ (pi / 200))
  Char 'z' -> onCoord cRadius succ
  Char 'X' -> onCoord cTheta (flip (-) (pi / 200))
  Char 'Y' -> onCoord cPhi (flip (-) (pi / 200))
  Char 'Z' -> onCoord cRadius pred
  Char 'l' -> toggleFlag ps Lights
  Char 's' -> toggleFlag ps Flags
  Char 'i' -> toggleFlag ps Main.Info
  Char 'e' -> toggleFlag ps ExtraInfo
  Char 'd' -> toggleFlag ps DragInfo
  Char 'm' -> toggleFlag ps MouseInfo
  Char 't' -> toggleFlag ps ShiftInfo
  Char 'p' -> toggleFlag ps FramesPerSecond
  Char 'M' -> toggleFlag ps Middle
  Char 'S' -> toggleFlag ps Shapes
  Char 'a' -> toggleFlag ps Axis
  Char 'n' -> advanceFocus ps

  MouseButton LeftButton -> setB leftButton
  MouseButton RightButton -> setB rightButton
  MouseButton MiddleButton -> setB middleButton
  MouseButton WheelDown -> get ps >>= \p -> ps $$! p & cameraShift . cRadius
                                            %~ succ
  _ -> return ()
  where
    setB f = do
      p <- get ps
      ps $$! p & mouseState . f .~ Down & dragState . _2 .~ Nothing

    onCoord f g = get ps >>= \p -> ps $$! p & cameraShift . f %~ g


keyboardMouse :: IORef ProgramState -> KeyboardMouseCallback
keyboardMouse ps key Down _ _ = case key of
  Char 'q' -> exitSuccess
  Char 'f'-> toggleFlag ps Main.Fill
  Char 'r' -> get ps >>= \p -> ps $$! p & cameraShift
                               .~ defaultState ^. cameraShift
  Char 'x' -> onCoord cTheta (+ (pi / 200))
  Char 'y' -> onCoord cPhi (+ (pi / 200))
  Char 'z' -> onCoord cRadius succ
  Char 'X' -> onCoord cTheta (flip (-) (pi / 200))
  Char 'Y' -> onCoord cPhi (flip (-) (pi / 200))
  Char 'Z' -> onCoord cRadius pred
  Char 'l' -> toggleFlag ps Lights
  Char 's' -> toggleFlag ps Flags
  Char 'i' -> toggleFlag ps Main.Info
  Char 'e' -> toggleFlag ps ExtraInfo
  Char 'd' -> toggleFlag ps DragInfo
  Char 'm' -> toggleFlag ps MouseInfo
  Char 't' -> toggleFlag ps ShiftInfo
  Char 'p' -> toggleFlag ps FramesPerSecond
  Char 'M' -> toggleFlag ps Middle
  Char 'S' -> toggleFlag ps Shapes
  Char 'a' -> toggleFlag ps Axis
  Char 'n' -> advanceFocus ps

  MouseButton LeftButton -> setB leftButton
  MouseButton RightButton -> setB rightButton
  MouseButton MiddleButton -> setB middleButton
  MouseButton WheelDown -> get ps >>= \p -> ps $$! p & cameraShift . cRadius
                                            %~ succ
  _ -> return ()
  where
    setB f = do
      p <- get ps
      ps $$! p & mouseState . f .~ Down & dragState . _2 .~ Nothing

    onCoord f g = get ps >>= \p -> ps $$! p & cameraShift . f %~ g
keyboardMouse ps key Down _ _ = case key of
  Char 'q' -> exitSuccess
  Char 'f'-> toggleFlag ps Main.Fill
  Char 'r' -> get ps >>= \p -> ps $$! p & cameraShift
                               .~ defaultState ^. cameraShift
  Char 'x' -> onCoord cTheta (+ (pi / 200))
  Char 'y' -> onCoord cPhi (+ (pi / 200))
  Char 'z' -> onCoord cRadius succ
  Char 'X' -> onCoord cTheta (flip (-) (pi / 200))
  Char 'Y' -> onCoord cPhi (flip (-) (pi / 200))
  Char 'Z' -> onCoord cRadius pred
  Char 'l' -> toggleFlag ps Lights
  Char 's' -> toggleFlag ps Flags
  Char 'i' -> toggleFlag ps Main.Info
  Char 'e' -> toggleFlag ps ExtraInfo
  Char 'd' -> toggleFlag ps DragInfo
  Char 'm' -> toggleFlag ps MouseInfo
  Char 't' -> toggleFlag ps ShiftInfo
  Char 'p' -> toggleFlag ps FramesPerSecond
  Char 'M' -> toggleFlag ps Middle
  Char 'S' -> toggleFlag ps Shapes
  Char 'a' -> toggleFlag ps Axis
  Char 'n' -> advanceFocus ps

  MouseButton LeftButton -> setB leftButton
  MouseButton RightButton -> setB rightButton
  MouseButton MiddleButton -> setB middleButton
  MouseButton WheelDown -> get ps >>= \p -> ps $$! p & cameraShift . cRadius
                                            %~ succ
  _ -> return ()
  where
    setB f = do
      p <- get ps
      ps $$! p & mouseState . f .~ Down & dragState . _2 .~ Nothing

    onCoord f g = get ps >>= \p -> ps $$! p & cameraShift . f %~ g