├── Setup.hs ├── default.nix ├── shell.nix ├── stack.yaml ├── .gitignore ├── virtual-piano.cabal ├── LICENSE ├── nix ├── main.nix └── fetch-nixpkgs.nix ├── README.md └── src └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ./nix/main.nix {}).haskellPackages."virtual-piano" 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let drv = import ./default.nix; 2 | in if builtins.getEnv "IN_NIX_SHELL" != "" then drv.env else drv 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.12 2 | packages: 3 | - . 4 | extra-deps: 5 | - 'Stream-0.4.7.2' 6 | - 'PortMidi-0.1.5.2' 7 | - 'arrows-0.4.4.1' 8 | - 'Euterpea-2.0.4' 9 | - 'lazysmallcheck-0.6' 10 | - 'ncurses-0.2.16' 11 | flags: {} 12 | extra-package-dbs: [] 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | result* 22 | -------------------------------------------------------------------------------- /virtual-piano.cabal: -------------------------------------------------------------------------------- 1 | name: virtual-piano 2 | version: 0.1.0.0 3 | author: Joomy Korkut 4 | maintainer: joomy@cattheory.com 5 | copyright: 2017 Joomy Korkut 6 | extra-source-files: README.md 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable virtual-piano 11 | hs-source-dirs: src 12 | main-is: Main.hs 13 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 14 | build-depends: base >= 4.7 && < 5 15 | , Euterpea 16 | , ncurses 17 | default-language: Haskell2010 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Joomy Korkut 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /nix/main.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | 3 | rec { 4 | fetchNixpkgs = import ./fetch-nixpkgs.nix; 5 | 6 | nixpkgs = fetchNixpkgs { 7 | rev = "19879836d10f64a10658d1e2a84fc54b090e2087"; 8 | sha256 = "0x7xa9xgdraqxhhz548nng5gcs37193zvq8v9ngbqd2lzn2dm4hd"; 9 | inherit system; 10 | }; 11 | 12 | pkgs = import nixpkgs { 13 | config = { allowUnfree = true; overrides = []; }; 14 | inherit system; 15 | }; 16 | 17 | filterPath = path: ( 18 | with { 19 | sf = name: type: let bn = baseNameOf (toString name); in !( 20 | (type == "directory" && (bn == ".git")) 21 | || pkgs.lib.hasSuffix "~" bn 22 | || pkgs.lib.hasSuffix ".o" bn 23 | || pkgs.lib.hasSuffix ".so" bn 24 | || pkgs.lib.hasSuffix ".nix" bn 25 | || (type == "symlink" && pkgs.lib.hasPrefix "result" bn) 26 | ); 27 | }; 28 | builtins.filterSource sf path); 29 | 30 | source = filterPath ./..; 31 | 32 | haskellPackages = pkgs.haskellPackages.override { 33 | overrides = self: super: { 34 | PortMidi = self.callHackage "PortMidi" "0.1.5.2" {}; 35 | virtual-piano = self.callCabal2nix "virtual-piano" source {}; 36 | }; 37 | }; 38 | } 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # virtual-piano 2 | Terminal based virtual piano in Haskell, with ncurses and Euterpea. Very rudimentary implementation, but it plays notes! 3 | 4 | [Euterpea requires that you have a default MIDI device on your computer.](http://www.euterpea.com/euterpea/setting-up-midi/) 5 | 6 | ![Screenshot](https://i.imgur.com/GzHtyva.png) 7 | 8 | The current implementation is just a proof of concept. I'll get back to this project when I learn more about concurrency in Haskell. (I'm a bit ashamed that currently I'm `forkIO`ing for every note, which is terrible.) Feel free to fork and/or send pull requests! 9 | 10 | TODO: 11 | 12 | * Fix concurrency! There are errors if you play more than 4-5 notes at the same time. (as in, when the previous ones aren't finished playing yet.) 13 | * Keep the notes playing if the key stays pressed? Silence the note when the key is released? I don't even know how this would be possible with ncurses. 14 | * Changing the color of the pressed key as it is pressed. 15 | * Command line options to change the size of the keyboard, range etc. Graphics completely depend on `Options` so this shouldn't be too difficult with `optparse-applicative`. 16 | 17 | # Usage 18 | 19 | ``` 20 | stack install 21 | virtual-piano 22 | ``` 23 | 24 | Then type the characters written on the keys to play them. The character order is supposed to resemble an ANSI QWERTY keyboard. 25 | 26 | You can press escape or backtick to exit the program. 27 | -------------------------------------------------------------------------------- /nix/fetch-nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { rev # The Git revision of nixpkgs to fetch 2 | , sha256 # The SHA256 of the downloaded data 3 | , system ? builtins.currentSystem # This is overridable if necessary 4 | }: 5 | 6 | with { 7 | ifThenElse = { bool, thenValue, elseValue }: ( 8 | if bool then thenValue else elseValue); 9 | }; 10 | 11 | ifThenElse { 12 | bool = (0 <= builtins.compareVersions builtins.nixVersion "1.12"); 13 | 14 | # In Nix 1.12, we can just give a `sha256` to `builtins.fetchTarball`. 15 | thenValue = ( 16 | builtins.fetchTarball { 17 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 18 | inherit sha256; 19 | }); 20 | 21 | # This hack should at least work for Nix 1.11 22 | elseValue = ( 23 | (rec { 24 | tarball = import { 25 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 26 | inherit sha256; 27 | }; 28 | 29 | builtin-paths = import ; 30 | 31 | script = builtins.toFile "nixpkgs-unpacker" '' 32 | "$coreutils/mkdir" "$out" 33 | cd "$out" 34 | "$gzip" --decompress < "$tarball" | "$tar" -x --strip-components=1 35 | ''; 36 | 37 | nixpkgs = builtins.derivation { 38 | name = "nixpkgs-${builtins.substring 0 6 rev}"; 39 | 40 | builder = builtins.storePath builtin-paths.shell; 41 | 42 | args = [ script ]; 43 | 44 | inherit tarball system; 45 | 46 | tar = builtins.storePath builtin-paths.tar; 47 | gzip = builtins.storePath builtin-paths.gzip; 48 | coreutils = builtins.storePath builtin-paths.coreutils; 49 | }; 50 | }).nixpkgs); 51 | } 52 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Concurrent (forkIO) 5 | import Control.Monad (forM_) 6 | import Control.Monad.IO.Class (liftIO) 7 | import Data.List (partition, find) 8 | import Data.Maybe (catMaybes) 9 | import Euterpea 10 | import UI.NCurses 11 | 12 | data Options = Options { 13 | range :: [AbsPitch] 14 | , controls :: [Char] 15 | , firstKeyRow :: Integer 16 | , firstKeyColumn :: Integer 17 | , whiteKeyWidth :: Integer 18 | , whiteKeyHeight :: Integer 19 | , blackKeyWidth :: Integer 20 | , blackKeyHeight :: Integer 21 | , windowRows :: Integer 22 | , windowCols :: Integer 23 | } 24 | 25 | initialOptions :: Options 26 | initialOptions = Options [48..88] 27 | "1234567890-=\bqwertyuiop[]\\asdfghjkl;'\nzxcvbnm,./" 28 | 0 0 6 10 4 6 0 0 29 | 30 | data Toolbox = Toolbox { 31 | whiteKeyColor :: ColorID 32 | , blackKeyColor :: ColorID 33 | , pressedKeyColor :: ColorID 34 | } 35 | 36 | data PianoKey = PianoKey { 37 | absP :: AbsPitch 38 | , control :: Char 39 | , name :: String 40 | , isBlack :: Bool 41 | , column :: Integer 42 | , pressed :: Bool 43 | } deriving Show 44 | 45 | keyName :: AbsPitch -> String 46 | keyName = renameSharp . f . pitch 47 | where f (x, y) = show x ++ show y 48 | renameSharp = map $ \case 's' -> '#' ; c -> c 49 | 50 | showControl :: Char -> String 51 | showControl '\n' = "↵" 52 | showControl '\\' = "\\" 53 | showControl '\'' = "'" 54 | showControl '\b' = "⌫" 55 | showControl c = init $ tail $ show $ c 56 | 57 | isBlackKey :: AbsPitch -> Bool 58 | isBlackKey i = fst (pitch i) `elem` [As,Cs,Ds,Fs,Gs] 59 | 60 | keys :: Options -> [PianoKey] 61 | keys Options{..} = catMaybes $ scanl f Nothing (zip range controls) 62 | where 63 | f Nothing (i, c) = Just $ PianoKey i c (keyName i) (isBlackKey i) firstKeyColumn False 64 | f (Just PianoKey{..}) (i, c) = Just $ PianoKey i c (keyName i) (isBlackKey i) col False 65 | where col = case (isBlack, isBlackKey i) of -- are the prev and curr keys black 66 | (False, True) -> column + (div whiteKeyWidth 2) + 1 67 | (False, False) -> column + whiteKeyWidth 68 | (True, False) -> column + (div blackKeyWidth 2) 69 | _ -> error "Impossible: Two black keys cannot be consecutive" 70 | 71 | drawKey :: Options -> Toolbox -> PianoKey -> Update () 72 | drawKey Options{..} Toolbox{..} PianoKey{..} = do 73 | let width = if isBlack then blackKeyWidth else whiteKeyWidth 74 | let height = if isBlack then blackKeyHeight else whiteKeyHeight 75 | let r = firstKeyRow 76 | let c = column 77 | setColor $ if pressed then pressedKeyColor else 78 | if isBlack then blackKeyColor else whiteKeyColor 79 | -- draw the background 80 | moveCursor r c 81 | forM_ [r..(r + height)] $ \n -> do 82 | moveCursor n c 83 | drawString $ replicate (fromInteger width) ' ' 84 | -- draw the borders of the box 85 | setColor $ if isBlack then blackKeyColor else whiteKeyColor 86 | moveCursor r c ; drawLineH (Just glyphLineH) width 87 | moveCursor (r + height) c ; drawLineH (Just glyphLineH) width 88 | moveCursor r c ; drawLineV (Just glyphLineV) height 89 | moveCursor r (c + width) ; drawLineV (Just glyphLineV) height 90 | moveCursor (r + height) c ; drawGlyph glyphCornerLL 91 | moveCursor r (c + width) ; drawGlyph glyphCornerUR 92 | moveCursor (r + height) (c + width) ; drawGlyph glyphCornerLR 93 | moveCursor r c ; drawGlyph glyphCornerUL 94 | moveCursor (firstKeyRow + height - 2) (c + 1) 95 | drawString name 96 | moveCursor (firstKeyRow + height - 1) (c + 1) 97 | drawString $ showControl control 98 | 99 | waitFor :: Window -> (Event -> Curses Bool) -> Curses () 100 | waitFor w p = loop where 101 | loop = do 102 | ev <- getEvent w Nothing 103 | case ev of 104 | Nothing -> loop 105 | Just ev' -> do 106 | b <- p ev' 107 | if b then return () else loop 108 | 109 | main :: IO () 110 | main = runCurses $ do 111 | setEcho False 112 | w <- defaultWindow 113 | toolbox <- Toolbox <$> newColorID ColorBlack ColorWhite 1 114 | <*> newColorID ColorWhite ColorBlack 2 115 | <*> newColorID ColorBlack ColorYellow 3 116 | let options = initialOptions 117 | updateWindow w $ do 118 | (sizeR, sizeC) <- windowSize 119 | let options = initialOptions { 120 | windowRows = sizeR 121 | , windowCols = sizeC 122 | } 123 | let (blacks, whites) = partition isBlack (keys options) 124 | let whiteCount = fromIntegral (length whites) 125 | let options = initialOptions { 126 | firstKeyRow = (div sizeR 2) - (div (whiteKeyHeight options) 2) 127 | , firstKeyColumn = (div sizeC 2) - (div (whiteKeyWidth options * whiteCount) 2) 128 | } 129 | -- update the locations for the keys 130 | let (blacks, whites) = partition isBlack (keys options) 131 | forM_ whites $ drawKey options toolbox -- draw white keys first 132 | forM_ blacks $ drawKey options toolbox -- draw black keys over the white keys 133 | moveCursor 0 0 134 | render 135 | waitFor w $ \ev -> do 136 | case ev of 137 | EventCharacter c -> do 138 | case find ((== c) . control) (keys options) of 139 | Nothing -> return () 140 | Just key -> do 141 | liftIO $ forkIO $ play $ note 1 (absP key) -- ugh 142 | return () 143 | _ -> return () 144 | return $ ev `elem` map EventCharacter ['\ESC', '`'] 145 | --------------------------------------------------------------------------------