├── demos ├── functions │ ├── k.nf │ ├── fnwriter.nf │ ├── fnreader.nf │ ├── beat.nf │ └── rundemo.sh ├── execute │ ├── exec3.nf │ ├── exec2.nf │ ├── exec1.nf │ └── rundemo.sh ├── buffers │ ├── hello.nf │ ├── world.nf │ └── rundemo.sh ├── forks │ └── fork.nf ├── drums │ ├── beat.nf │ ├── rundemo.sh │ └── drums.nf ├── mem │ └── swapper.nf └── song.cfg ├── noisefunge.env ├── nfops └── nfops.hs ├── nfreset └── nfreset.hs ├── nfloader └── nfloader.hs ├── nfkill └── nfkill.hs ├── src └── Language │ ├── NoiseFunge │ ├── Note.hs │ ├── Beat.hs │ ├── API.hs │ ├── Befunge.hs │ ├── Engine.hs │ ├── Server │ │ └── Comm.hs │ ├── Befunge │ │ ├── Process.hs │ │ ├── Operator.hs │ │ └── VM.hs │ ├── Server.hs │ └── ALSA.hs │ └── NoiseFunge.hs ├── nfviewer ├── Tiler.hs └── nfviewer.hs ├── noisefunge.cabal ├── funged └── funged.hs ├── nftop └── nftop.hs ├── README.md └── LICENSE /demos/functions/k.nf: -------------------------------------------------------------------------------- 1 | >[*6Ck[@ 2 | -------------------------------------------------------------------------------- /demos/execute/exec3.nf: -------------------------------------------------------------------------------- 1 | >"97972"v 2 | ^ ..... < 3 | -------------------------------------------------------------------------------- /demos/execute/exec2.nf: -------------------------------------------------------------------------------- 1 | >"52590"v 2 | v..... < 3 | >~~~~~v 4 | ^ .....< 5 | -------------------------------------------------------------------------------- /demos/buffers/hello.nf: -------------------------------------------------------------------------------- 1 | > "HELLO "v 2 | v ...... < 3 | > ~~~~~~ v 4 | v ,,,,,, < 5 | ^< 6 | -------------------------------------------------------------------------------- /demos/buffers/world.nf: -------------------------------------------------------------------------------- 1 | > "WORLD "v 2 | v ~~~~~~ < 3 | > ,,,,,, v 4 | v ...... < 5 | ^< 6 | -------------------------------------------------------------------------------- /demos/functions/fnwriter.nf: -------------------------------------------------------------------------------- 1 | >[Zxkl[v 2 | v < 3 | >[Zx-5kl[v 4 | v[LkA-xZ[< 5 | ^< 6 | -------------------------------------------------------------------------------- /demos/forks/fork.nf: -------------------------------------------------------------------------------- 1 | >[|&::-1g[v 2 | v"ork"< v9< 3 | >"f",v g 4 | @ ,,,<|K< 5 | >$ ^ 6 | -------------------------------------------------------------------------------- /demos/functions/fnreader.nf: -------------------------------------------------------------------------------- 1 | >2C5*CA*1zv 2 | ^ vK&~< 3 | v L _ K| 4 | l@ L < 5 | > l ^ 6 | -------------------------------------------------------------------------------- /demos/drums/beat.nf: -------------------------------------------------------------------------------- 1 | >1; v 2 | 2 3 | ; 4 | 5 | 6 | 7 | ; 8 | 4 9 | ^ ;3< 10 | -------------------------------------------------------------------------------- /demos/drums/rundemo.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | nfloader beat.nf beat beat 4 | nfloader drums.nf beat beat 5 | 6 | -------------------------------------------------------------------------------- /demos/functions/beat.nf: -------------------------------------------------------------------------------- 1 | >1; v 2 | 2 3 | ; 4 | 5 | 6 | 7 | ; 8 | 4 9 | ^ ;3< 10 | -------------------------------------------------------------------------------- /demos/mem/swapper.nf: -------------------------------------------------------------------------------- 1 | >" " v< 2 | HELLO 3 | WORLD p 4 | v:::R04<0 5 | >1g00pv 0 6 | vp1\g2< : 7 | >00g\2p ^ 8 | -------------------------------------------------------------------------------- /demos/execute/exec1.nf: -------------------------------------------------------------------------------- 1 | >0099*2zv 2 | $ 3 | ^v':-1<6< 4 | ~ Z 5 | e q 6 | 5 & 7 | C : 8 | >*+x ^ 9 | -------------------------------------------------------------------------------- /demos/execute/rundemo.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | nfloader exec1.nf buf0 buf0 4 | nfloader exec2.nf buf1 buf0 5 | nfloader exec3.nf buf0 buf1 6 | 7 | -------------------------------------------------------------------------------- /demos/drums/drums.nf: -------------------------------------------------------------------------------- 1 | >93C*AB*1z0>$~v 2 | v:X4+x^ 7 | x~x x 8 | Z Z @ Z < 9 | >^>^ < 10 | -------------------------------------------------------------------------------- /demos/buffers/rundemo.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | nfloader hello.nf buf0 buf1 4 | nfloader world.nf buf0 buf1 5 | sleep 2 6 | nfloader hello.nf buf1 buf0 7 | nfloader world.nf buf1 buf0 8 | 9 | -------------------------------------------------------------------------------- /demos/functions/rundemo.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | nfloader beat.nf beat beat 4 | nfloader k.nf beat beat 5 | sleep 5 6 | nfloader fnwriter.nf beat beat 7 | sleep 5 8 | nfloader fnreader.nf beat beat 9 | -------------------------------------------------------------------------------- /noisefunge.env: -------------------------------------------------------------------------------- 1 | export NOISEFUNGE_SERVER_HOST=127.0.0.1 2 | export NOISEFUNGE_SERVER_PORT=4545 3 | export NOISEFUNGE_HOST=127.0.0.1 4 | export PATH=$(readlink -f .cabal-sandbox/bin/):$PATH 5 | 6 | -------------------------------------------------------------------------------- /nfops/nfops.hs: -------------------------------------------------------------------------------- 1 | 2 | import Language.NoiseFunge 3 | import Control.Lens 4 | import Text.Printf 5 | import Control.Monad 6 | 7 | main :: IO () 8 | main = void $ flip traverse stdOps $ \o -> do 9 | printf "%16s %c %s\n" (o^.opName) (o^.opChar) (o^.opDesc) 10 | 11 | -------------------------------------------------------------------------------- /demos/song.cfg: -------------------------------------------------------------------------------- 1 | beats = 120 2 | subbeats = 8 3 | 4 | [server1] 5 | host = 0.0.0.0 6 | port = 4545 7 | 8 | [port0] 9 | connection = FLUID Synth (Qsynth1) 10 | starting_channel = 0 11 | 12 | [port1] 13 | connection = FLUID Synth (Qsynth2) 14 | starting_channel = 16 15 | 16 | [port2] 17 | connection = FLUID Synth (Qsynth3) 18 | starting_channel = 32 19 | 20 | -------------------------------------------------------------------------------- /nfreset/nfreset.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | import Language.NoiseFunge.API 21 | 22 | main :: IO () 23 | main = do 24 | withAPIConnection requestReset 25 | 26 | -------------------------------------------------------------------------------- /nfloader/nfloader.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | import Language.NoiseFunge.API 21 | import System.Environment 22 | 23 | main :: IO () 24 | main = do 25 | args <- getArgs 26 | case args of 27 | [fname,inbuf,outbuf] -> do 28 | prog <- readFile fname 29 | withAPIConnection $ \conn -> do 30 | pid <- addProgram conn fname inbuf outbuf (lines prog) 31 | print pid 32 | _ -> error "Usage: nfloader FILENAME INBUF OUTBUF" 33 | 34 | -------------------------------------------------------------------------------- /nfkill/nfkill.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | import Control.Applicative 21 | import Options.Applicative 22 | import Language.NoiseFunge.API 23 | 24 | killSpec :: Parser Request 25 | killSpec = StopProgram 26 | <$> optional (option auto (long "pid" <> short 'p')) 27 | <*> optional (strOption (long "name" <> short 'n')) 28 | <*> optional (strOption (long "reason" <> short 'r')) 29 | 30 | desc :: InfoMod a 31 | desc = fullDesc 32 | <> header "nfkill - noisefunge process killer" 33 | 34 | main :: IO () 35 | main = do 36 | req <- execParser (info (helper <*> killSpec) desc) 37 | withAPIConnection $ \conn -> do 38 | sendBinary' req conn 39 | 40 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Note.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | module Language.NoiseFunge.Note (Note(Note), channel, pitch, 23 | velocity, duration) where 24 | 25 | import Control.Lens 26 | 27 | import Data.Default 28 | import Data.Word 29 | import Data.Binary 30 | 31 | data Note = Note { 32 | _channel :: !Word8, 33 | _pitch :: !Word8, 34 | _velocity :: !Word8, 35 | _duration :: !Word8 36 | } deriving (Read, Show, Eq, Ord) 37 | 38 | instance Default Note where 39 | def = Note 0 0 0 0 40 | 41 | instance Binary Note where 42 | get = Note <$> get <*> get <*> get <*> get 43 | put (Note c p v d) = put c >> put p >> put v >> put d 44 | 45 | $(makeLenses ''Note) 46 | 47 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | module Language.NoiseFunge (Tempo(..), bpm, subbeats, 21 | Beat(..), beat, subbeat, 22 | ServerConfig(..), 23 | OperatorParams(..), 24 | Operator, 25 | opName, opChar, opDesc, 26 | stdOps, 27 | ALSAPort(ALSAPort), portConnection, 28 | ALSAThreadConfig(ALSAThreadConfig), 29 | portStarting, 30 | runServer) where 31 | 32 | import Language.NoiseFunge.ALSA 33 | import Language.NoiseFunge.Beat 34 | import Language.NoiseFunge.Befunge 35 | import Language.NoiseFunge.Server 36 | 37 | import Language.NoiseFunge.Befunge.Process 38 | import Language.NoiseFunge.Befunge.Operator 39 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Beat.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | module Language.NoiseFunge.Beat (Tempo(Tempo), bpm, subbeats, 23 | Beat(Beat), beat, subbeat, 24 | (##), 25 | Beats, beats) where 26 | 27 | import Control.Lens 28 | 29 | import Data.Binary 30 | import Data.Default 31 | 32 | data Tempo = Tempo { 33 | _bpm :: !Word32, 34 | _subbeats :: !Word32 35 | } deriving (Read, Show, Eq, Ord) 36 | 37 | $(makeLenses ''Tempo) 38 | 39 | data Beat = Beat { 40 | _beat :: !Word32, 41 | _subbeat :: !Word32 42 | } deriving (Read, Eq, Ord) 43 | 44 | $(makeLenses ''Beat) 45 | 46 | instance Binary Beat where 47 | get = Beat <$> get <*> get 48 | put (Beat x y) = put x >> put y 49 | 50 | instance Default Beat where 51 | def = Beat 0 0 52 | 53 | instance Show Beat where 54 | show (Beat x y) = shows x . showChar '|' . shows y $ [] 55 | 56 | type Beats = [Beat] 57 | 58 | (##) :: Tempo -> Beat -> Beat 59 | (Tempo _ sb) ## (Beat b s) = nb where 60 | s' = s + 1 61 | b' = b + 1 62 | nb = if s' == sb 63 | then (Beat b' 0) 64 | else (Beat b s') 65 | 66 | beats :: Tempo -> Beats 67 | beats t = iterate (t ##) def 68 | 69 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/API.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | module Language.NoiseFunge.API (Tempo(Tempo), bpm, subbeats, 21 | Beat(Beat), beat, subbeat, 22 | (##), 23 | Subscription(..), 24 | Request(..), 25 | Response(..), 26 | withAPIConnection, 27 | Conn, 28 | sendBinary', 29 | addProgram, 30 | requestReset, 31 | streamEvents, 32 | PID, BefungeStats, 33 | VMStats(..), 34 | ExecStats(..), 35 | vmPID, vmExec, vmMisc, 36 | ProgArray, 37 | ProcessStats, 38 | psTicks, psStackSize, 39 | psQuote, 40 | Dir(..), 41 | PC(..), 42 | pos, dir, Pos, 43 | Delta(..), 44 | oldpc, newpc, change, events, 45 | Event(..), 46 | ) where 47 | 48 | import Language.NoiseFunge.Beat 49 | import Language.NoiseFunge.Befunge 50 | import Language.NoiseFunge.Befunge.Process 51 | import Language.NoiseFunge.Befunge.VM 52 | import Language.NoiseFunge.Server.Comm 53 | 54 | -------------------------------------------------------------------------------- /nfviewer/Tiler.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | module Tiler (Point, Tile(..), Tiler, newTiler, tile, untile) where 21 | 22 | import System.Random 23 | import Control.Monad 24 | import Control.Monad.State 25 | import Control.Monad.Trans.Maybe 26 | import Control.Applicative 27 | import Data.Maybe 28 | 29 | type Point = (Integer, Integer) 30 | 31 | data Tiler = Tiler Integer Integer [(Point -> Maybe Tile) -> Point -> Maybe Tile] 32 | 33 | windowFun :: Tiler -> Point -> Maybe Tile 34 | windowFun (Tiler _ _ tiles) = foldr (.) id tiles (const Nothing) 35 | 36 | data Tile = Tile Char Point Point 37 | deriving (Read, Show, Eq, Ord) 38 | 39 | instance Show Tiler where 40 | show win@(Tiler rows cols _) = showRows "" where 41 | tiles = windowFun win 42 | showRows = foldr (.) id [showRow r | r <- [0..rows - 1]] 43 | showRow r = foldr (.) (showChar '\n') $ do 44 | c <- [0.. cols - 1] 45 | case tiles (r,c) of 46 | Nothing -> return $ showChar ' ' 47 | Just (Tile ch _ _) -> return $ showChar ch 48 | 49 | newTiler :: Integer -> Integer -> Tiler 50 | newTiler rows cols = Tiler rows cols [] 51 | 52 | addTile :: Tile -> Tiler -> Tiler 53 | addTile tile (Tiler rows cols tiles) = win where 54 | win = Tiler rows cols (tilefn:tiles) 55 | Tile _ (rmin, cmin) (rmax, cmax) = tile 56 | tilefn sub (r, c) = 57 | if r >= rmin && r <= rmax && c >= cmin && c <= cmax 58 | then return tile 59 | else sub (r, c) 60 | 61 | tile :: RandomGen g => Integer -> Char -> Integer -> Integer -> Tiler -> g -> 62 | (Maybe (Tile, Tiler), g) 63 | tile tries ch h w win@(Tiler rows cols _) = finder where 64 | finder = runState (runMaybeT (findSpot tries)) 65 | tiles = windowFun win 66 | rrange = (0, rows - h) 67 | crange = (0, cols - w) 68 | tryCorns r c = msum $ fmap tiles [(r,c),(r+h-1,c),(r,c+w-1),(r+h-1,c+w-1)] 69 | trySpot r c = msum $ do 70 | r' <- [r..r+h-1] 71 | c' <- [c..c+w-1] 72 | return $ tiles (r', c') 73 | findSpot 0 = fail "no match" 74 | findSpot n = (<|> findSpot (n - 1)) $ do 75 | r <- state (randomR rrange) 76 | c <- state (randomR crange) 77 | case tryCorns r c <|> trySpot r c of 78 | Nothing -> 79 | let tile = Tile ch (r,c) (r+h-1, c+w-1) 80 | win' = addTile tile win 81 | in return (tile, win') 82 | _ -> fail "occupied" 83 | 84 | untile :: Tile -> Tiler -> Tiler 85 | untile (Tile _ p _) (Tiler rows cols tiles) = Tiler rows cols tiles' where 86 | tiles' = filter (\f -> isNothing (f (const Nothing) p)) tiles 87 | 88 | -------------------------------------------------------------------------------- /noisefunge.cabal: -------------------------------------------------------------------------------- 1 | name: noisefunge 2 | version: 0.0.1 3 | synopsis: A live-coding obfuscated programming language 4 | cabal-version: >= 1.8 5 | license: GPL-3 6 | build-type: Simple 7 | 8 | library 9 | hs-source-dirs: src 10 | exposed-modules: Language.NoiseFunge, 11 | Language.NoiseFunge.API 12 | other-modules: Language.NoiseFunge.ALSA, 13 | Language.NoiseFunge.Beat, 14 | Language.NoiseFunge.Befunge, 15 | Language.NoiseFunge.Befunge.Operator, 16 | Language.NoiseFunge.Befunge.Process, 17 | Language.NoiseFunge.Befunge.VM, 18 | Language.NoiseFunge.Engine, 19 | Language.NoiseFunge.Note, 20 | Language.NoiseFunge.Server, 21 | Language.NoiseFunge.Server.Comm 22 | 23 | build-depends: base >= 4.9 && < 5, 24 | alsa-core, 25 | alsa-seq, 26 | midi, 27 | ConfigFile >= 1.1.4, 28 | mtl, 29 | transformers, 30 | random, 31 | array, 32 | stm, 33 | lens, 34 | containers, 35 | data-default, 36 | bytestring, 37 | explicit-exception, 38 | stm, 39 | network, 40 | binary 41 | 42 | Ghc-options: -Wall -O2 -threaded -funbox-strict-fields 43 | 44 | executable funged 45 | hs-source-dirs: funged 46 | main-is: funged.hs 47 | build-depends: base >= 4.9 && < 5, 48 | noisefunge, 49 | mtl, 50 | array, 51 | containers, 52 | transformers, 53 | network, 54 | ConfigFile 55 | 56 | Ghc-options: -Wall -O2 -threaded 57 | 58 | executable nfviewer 59 | hs-source-dirs: nfviewer 60 | main-is: nfviewer.hs 61 | other-modules: Tiler 62 | 63 | build-depends: base >= 4.9 && < 5, 64 | noisefunge, 65 | mtl, 66 | array, 67 | transformers, 68 | ncurses, 69 | lens, 70 | random, 71 | optparse-applicative, 72 | containers 73 | 74 | Ghc-options: -Wall -O2 -threaded 75 | 76 | executable nftop 77 | hs-source-dirs: nftop 78 | main-is: nftop.hs 79 | 80 | build-depends: base >= 4.9 && < 5, 81 | noisefunge, 82 | mtl, 83 | array, 84 | transformers, 85 | ncurses, 86 | lens, 87 | data-default, 88 | containers 89 | 90 | Ghc-options: -Wall -O2 -threaded 91 | 92 | executable nfloader 93 | hs-source-dirs: nfloader 94 | main-is: nfloader.hs 95 | 96 | build-depends: base >= 4.9 && < 5, 97 | noisefunge, 98 | mtl, 99 | array, 100 | transformers, 101 | lens, 102 | containers 103 | 104 | Ghc-options: -Wall -O2 -threaded 105 | 106 | executable nfkill 107 | hs-source-dirs: nfkill 108 | main-is: nfkill.hs 109 | 110 | build-depends: base >= 4.9 && < 5, 111 | noisefunge, 112 | mtl, 113 | transformers, 114 | lens, 115 | containers, 116 | optparse-applicative 117 | 118 | Ghc-options: -Wall -O2 -threaded 119 | 120 | executable nfreset 121 | hs-source-dirs: nfreset 122 | main-is: nfreset.hs 123 | 124 | build-depends: base >= 4.9 && < 5, 125 | noisefunge 126 | Ghc-options: -Wall -O2 -threaded 127 | 128 | executable nfops 129 | hs-source-dirs: nfops 130 | main-is: nfops.hs 131 | 132 | build-depends: base >= 4.9 && < 5, 133 | noisefunge, 134 | lens, 135 | containers 136 | 137 | Ghc-options: -Wall -O2 -threaded 138 | 139 | -------------------------------------------------------------------------------- /funged/funged.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE FlexibleContexts, TupleSections #-} 21 | 22 | import Control.Applicative 23 | import Control.Monad 24 | import Control.Monad.Trans 25 | import Control.Monad.Error 26 | import Control.Monad.Identity 27 | 28 | import Data.ConfigFile as CF 29 | import qualified Data.Map as M 30 | import Network.Socket 31 | 32 | import System.Environment 33 | import System.IO 34 | 35 | import Language.NoiseFunge 36 | 37 | getConfFile :: ErrorT (CPErrorData, [Char]) IO String 38 | getConfFile = do 39 | args <- liftIO $ getArgs 40 | env <- lookup "NOISEFUNGE_CONFIG" <$> liftIO getEnvironment 41 | case (args, env) of 42 | ((conf:_), _) -> return conf 43 | ([], Just env') -> return env' 44 | _ -> fail "No config file" 45 | 46 | parseConf :: (MonadError CPError m, Functor m, Applicative m, MonadIO m, 47 | Alternative m) => ConfigParser -> m ServerConfig 48 | parseConf conf = sc where 49 | sc = ServerConfig <$> 50 | (concat <$> parseHosts) <*> 51 | parseALSAConfig <*> 52 | parseOpParams <*> 53 | parsePreloads <*> 54 | get conf "DEFAULT" "packet_size" 55 | 56 | servers = [srv | srv <- sections conf, "server" == take 6 srv] 57 | preloads = [pre | pre <- sections conf, "preload" == take 7 pre] 58 | parseHosts = forM servers $ \sect -> do 59 | h <- get conf sect "host" 60 | p <- get conf sect "port" 61 | let hints = Just defaultHints {addrSocketType = Datagram } 62 | ais <- liftIO $ getAddrInfo hints (Just h) (Just p) 63 | forM ais $ \ai -> do 64 | return (addrFamily ai, addrAddress ai) 65 | parsePreloads = forM preloads $ \sect -> do 66 | f <- get conf sect "file" 67 | ib <- get conf sect "inbuf" 68 | ob <- get conf sect "outbuf" 69 | return (f, ib, ob) 70 | parseALSAConfig = ALSAThreadConfig <$> 71 | parseTempo <*> 72 | (M.fromList <$> parsePorts) <*> 73 | get conf "DEFAULT" "note_limiter" 74 | ports = [prt | prt <- sections conf, "port" == take 4 prt] 75 | parsePorts = forM ports $ \sect -> do 76 | conn <- Just <$> get conf sect "connection" <|> return Nothing 77 | chan <- get conf sect "starting_channel" <|> return 0 78 | return (sect, ALSAPort conn chan) 79 | parseTempo = Tempo 80 | <$> get conf "DEFAULT" "beats" 81 | <*> get conf "DEFAULT" "subbeats" 82 | parseOpParams = OperatorParams 83 | <$> not <$> get conf "DEFAULT" "ignoreerror" 84 | <*> get conf "DEFAULT" "wrap" 85 | <*> get conf "DEFAULT" "debug" 86 | 87 | defaultConf :: ConfigParser 88 | Right defaultConf = defConf where 89 | defConf = runIdentity $ runErrorT $ 90 | return emptyCP >>= 91 | setDef "DEFAULT" "packet_size" "4096" >>= 92 | setDef "DEFAULT" "ignoreerror" "False" >>= 93 | setDef "DEFAULT" "wrap" "False" >>= 94 | setDef "DEFAULT" "debug" "False" >>= 95 | setDef "DEFAULT" "note_limiter" "True" >>= 96 | addSec "port0" >>= 97 | setDef "port0" "starting_channel" "0" 98 | setDef s k v cp = set cp s k v 99 | addSec n cp = add_section cp n 100 | 101 | main :: IO () 102 | main = do 103 | conf <- runErrorT $ do 104 | file <- getConfFile 105 | conf <- join $ liftIO $ readfile defaultConf file 106 | parseConf conf 107 | case conf of 108 | (Left err) -> hPutStrLn stderr (show err) 109 | (Right conf') -> runServer conf' 110 | 111 | -------------------------------------------------------------------------------- /nftop/nftop.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell, TupleSections, DeriveDataTypeable #-} 21 | 22 | import Prelude hiding (catch) 23 | 24 | import Control.Applicative 25 | import Control.Exception 26 | import Control.Lens 27 | import Control.Monad.Trans 28 | import Control.Monad 29 | import qualified Control.Monad.State as S 30 | 31 | import qualified Data.Map as M 32 | import Data.Monoid 33 | import Data.Typeable 34 | 35 | import Text.Printf 36 | 37 | import UI.NCurses as Curses 38 | 39 | import Language.NoiseFunge.API 40 | 41 | data ViewerState = ViewerState { 42 | _procs :: M.Map PID BefungeStats 43 | } 44 | 45 | $(makeLenses ''ViewerState) 46 | 47 | main :: IO () 48 | main = withAPIConnection $ \conn -> do 49 | let loop = mainCurses conn `catch` handler 50 | handler Redraw = loop 51 | handler Quit = return () 52 | loop 53 | 54 | formatLine :: PrintfType t => VMStats ProcessStats -> t 55 | formatLine stats = formatted where 56 | formatted = printf fmt pnum pnam' t ex ss q 57 | fmt = "%6d %-14s %5s %-6s %5s %c" 58 | (pnum, pnam) = stats^.vmPID 59 | t = ticks (stats^.vmMisc.psTicks) 60 | ex = execs (stats^.vmExec) 61 | ss = ticks (stats^.vmMisc.psStackSize) 62 | q = if (stats^.vmMisc.psQuote) then 'Q' else ' ' 63 | pnam' = take 10 pnam 64 | 65 | data ViewerException = Redraw | Quit 66 | deriving (Show, Typeable) 67 | 68 | instance Exception ViewerException 69 | 70 | getAllEvents :: Window -> Curses [Curses.Event] 71 | getAllEvents w = allEvs where 72 | allEvs = do 73 | ev <- getEvent w (Just 0) 74 | case ev of 75 | Nothing -> return [] 76 | Just ev' -> (ev':) <$> allEvs 77 | 78 | mainCurses :: Conn -> IO () 79 | mainCurses conn = 80 | runCurses $ do 81 | setEcho False 82 | void $ setCursorMode CursorInvisible 83 | w <- defaultWindow 84 | (r, c) <- screenSize 85 | glob <- newColorID ColorBlack ColorWhite 1 86 | updateWindow w $ do 87 | moveCursor 1 0 88 | setColor glob 89 | drawString " PID Process Ticks Status Stack Q" 90 | let vs = ViewerState mempty 91 | blankLine = take (fromIntegral $ c - 1) $ repeat ' ' 92 | updateWindow w $ forM_ [2..r-1] $ \i -> do 93 | moveCursor i 0 94 | drawString blankLine 95 | void $ flip S.runStateT vs $ streamEvents [Stats] conn $ \ev -> do 96 | cevs <- lift $ getAllEvents w 97 | forM_ cevs $ \cev -> do 98 | case cev of 99 | EventResized -> throw Redraw 100 | EventCharacter 'q' -> liftIO $ throwIO Quit 101 | EventCharacter 'Q' -> liftIO $ throwIO Quit 102 | _ -> return () 103 | case ev of 104 | TickStats bt run rbl wbl ded -> do 105 | lift $ updateWindow w $ do 106 | moveCursor 0 0 107 | setColor defaultColorID 108 | let line = printf fmt (bt^.beat) (bt^.subbeat) 109 | run rbl wbl ded 110 | fmt = "%9d|%-4d X:%-4d R:%-4d W:%-4d H:%-4d" 111 | drawString line 112 | ps <- use procs 113 | lift $ updateWindow w $ do 114 | setColor defaultColorID 115 | forM_ [2..r-1] $ \i -> do 116 | moveCursor i 0 117 | drawString blankLine 118 | forM_ (zip [2..r-1] (M.elems ps)) $ \(i, p) -> do 119 | moveCursor i 0 120 | drawString (formatLine p) 121 | let ps' = M.filter (livingExec . (^.vmExec)) ps 122 | livingExec (EHalted _) = False 123 | livingExec _ = True 124 | procs .= ps' 125 | ProcessStats _ st -> do 126 | let pid = st^.vmPID 127 | procs.(at pid) .= Just st 128 | Reset -> throw Redraw 129 | _ -> return () 130 | lift $ render 131 | 132 | ticks :: (Show i, Integral i) => i -> String 133 | ticks n 134 | | n < 1000 = show n 135 | | n < 1000000 = show (n `div` 1000) ++ "K" 136 | | n < 1000000000 = show (n `div` 1000000) ++ "M" 137 | | otherwise = show (n `div` 1000000000) ++ "G" 138 | 139 | 140 | execs :: ExecStats -> [Char] 141 | execs ERunning = "X" 142 | execs (EHalted Nothing) = "H" 143 | execs (EHalted (Just m)) = 'H' : take 5 m 144 | execs (ERBlock buf) = 'R' : take 5 buf 145 | execs (EWBlock buf) = 'W' : take 5 buf 146 | 147 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Befunge.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell, FlexibleContexts #-} 21 | 22 | module Language.NoiseFunge.Befunge (BefungeCommand(..), 23 | OperatorParams(..), 24 | BefungeThread, PID, 25 | BefungeStats, 26 | beatIn, commIn, deltaOut, errOut, 27 | tick, startBefungeThread) where 28 | 29 | import Control.Applicative 30 | import Control.Concurrent hiding (yield) 31 | import Control.Concurrent.STM 32 | import Control.Lens 33 | import Control.Monad 34 | import Control.Monad.State 35 | import Control.Monad.Writer 36 | import Control.Monad.RWS 37 | 38 | import Data.Default 39 | import qualified Data.Map as M 40 | 41 | import Language.NoiseFunge.Beat 42 | import Language.NoiseFunge.Befunge.VM 43 | import Language.NoiseFunge.Befunge.Process 44 | import Language.NoiseFunge.Befunge.Operator 45 | 46 | type BefungeStats = VMStats ProcessStats 47 | 48 | tick :: Fungine () 49 | tick = do 50 | q <- use quote 51 | fs <- use fnStack 52 | let opFn = case (q, fs) of 53 | (True, _) -> quoteOp 54 | (_, Just _) -> fnStackOp 55 | _ -> runOp 56 | getOp >>= opFn >> move 57 | ticks += 1 58 | yield 59 | 60 | data BefungeCommand = 61 | AddProcess ProgArray String String String (Maybe (MVar PID)) 62 | | KillProcess (PID -> Bool) (Maybe String) 63 | 64 | data BefungeThread = BefungeThread { 65 | _beatIn :: TMVar Beat, 66 | _commIn :: TChan BefungeCommand, 67 | _deltaOut :: TChan (Beat, [(PID, ProcessState, Delta)], 68 | [(PID, Maybe String)], [BefungeStats]), 69 | _errOut :: TChan String 70 | } 71 | 72 | $(makeLenses ''BefungeThread) 73 | 74 | data BefungeState = BefungeState { 75 | _bfsVM :: FungeVM, 76 | _bfsOps :: OpSet, 77 | _bfsBeats :: [Beat], 78 | _bfsLast :: Beat 79 | } 80 | 81 | $(makeLenses ''BefungeState) 82 | 83 | startBefungeThread :: Tempo -> OperatorParams -> IO (BefungeThread) 84 | startBefungeThread temp params = do 85 | bfth <- BefungeThread <$> newEmptyTMVarIO 86 | <*> newTChanIO 87 | <*> newTChanIO 88 | <*> newTChanIO 89 | vm <- newVM 90 | let bst = BefungeState vm operators (beats temp) def 91 | void . forkIO $ void $ runStateT (befungeRunner temp params bfth) bst 92 | return bfth 93 | 94 | flattenDeltas :: Deltas s -> [(PID, s, Delta)] 95 | flattenDeltas ds = trip <$> M.toList flat where 96 | maps = [M.singleton p (s, d) | (p, s, d) <- ds []] 97 | unionm (_, d1) (s, d2) = (s, d1 <> d2) 98 | flat = foldr (M.unionWith unionm) M.empty maps 99 | trip (a,(b,c)) = (a,b,c) 100 | 101 | befungeRunner :: Tempo -> OperatorParams -> BefungeThread -> 102 | StateT BefungeState IO () 103 | befungeRunner temp params bfth = forever $ readIn >>= handle where 104 | bin = bfth^.beatIn 105 | cin = bfth^.commIn 106 | dout = bfth^.deltaOut 107 | readIn = liftIO $ atomically $ (Right <$> takeTMVar bin) `orElse` 108 | (Left <$> readTChan cin) 109 | beat5 = let f = (temp ##) in f . f . f . f . f 110 | handle (Right btin) = do 111 | nextBeats <- bfsBeats %%= (span (beat5 btin /=)) 112 | forM_ nextBeats $ \bt -> do 113 | vm <- use bfsVM 114 | ops <- use bfsOps 115 | let (vm', ops', ds) = runRWS (advance bt vm) params ops 116 | dead = [(pid, msg) | (pid, msg, _) <- vm'^.deadProcesses] 117 | vmstats = fmap (^.processStats) <$> vm'^.vmStats 118 | liftIO . atomically $ 119 | writeTChan dout (bt, (flattenDeltas ds), dead, vmstats) 120 | bfsVM .= vm' 121 | bfsOps .= ops' 122 | bfsLast .= btin 123 | handle (Left (AddProcess arr name inbuf outbuf mv)) = do 124 | let p = befungeProgram arr inbuf outbuf 125 | newp <- bfsVM %%= (addProcess name p) 126 | let pid = newp^.procID 127 | case mv of 128 | Nothing -> return () 129 | Just mv' -> liftIO $ putMVar mv' pid 130 | handle (Left (KillProcess fn r)) = do 131 | let r' = ("Killed" ++) <$> (((": "++) <$> r) <|> Just "") 132 | fn' p = if fn (p^.procID) then kill r' p else p 133 | killall = fmap fn' 134 | zoom bfsVM $ do 135 | processQueue %= killall 136 | zoom (buffers.traverse) $ do 137 | readQueue %= killall 138 | writeQueue %= killall 139 | 140 | befungeProgram :: ProgArray -> String -> String -> FungeProgram 141 | befungeProgram arr inp out = program ps $ do 142 | tellMem 143 | forever tick 144 | where ps = makeProcessState arr inp out 145 | 146 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Engine.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | module Language.NoiseFunge.Engine (initNF, NoiseFungeEngine, 23 | beatEvents, startProgram, 24 | stopProgram, 25 | beatVar) where 26 | 27 | import Control.Applicative 28 | import Control.Concurrent 29 | import Control.Concurrent.STM 30 | import Control.Lens 31 | import Control.Monad 32 | import qualified Control.Monad.State as S 33 | import Control.Monad.Trans 34 | import Control.Monad.Writer 35 | 36 | import Data.Maybe 37 | import Data.Word 38 | 39 | import Language.NoiseFunge.ALSA 40 | import Language.NoiseFunge.Beat 41 | import Language.NoiseFunge.Befunge 42 | import Language.NoiseFunge.Befunge.Process 43 | 44 | 45 | data NoiseFungeEngine = NFE { 46 | _alsaThread :: ALSAThread, 47 | _funger :: BefungeThread 48 | } 49 | 50 | $(makeLenses ''NoiseFungeEngine) 51 | 52 | beatVar :: Getter NoiseFungeEngine (TVar Beat) 53 | beatVar = alsaThread.clock 54 | 55 | -- Initiate the NoiseFungeEngine 56 | initNF :: ALSAThreadConfig -> OperatorParams -> 57 | IO NoiseFungeEngine 58 | initNF conf pars = do 59 | -- start the ALSA thread 60 | alsa <- startALSAThread conf 61 | -- start the befunge thread 62 | bft <- startBefungeThread (conf^.alsaTempo) pars 63 | let nfe = NFE alsa bft 64 | 65 | -- read from the alsa clock and write the next beat to the 66 | -- noisefunge thread so that it will start computing the next 67 | -- set of events. 68 | void . forkIO $ beatStateHandler (alsa^.clock) $ \nextBeat -> do 69 | liftIO . atomically $ do 70 | b <- nextBeat 71 | putTMVar (bft^.beatIn) b 72 | return b 73 | delts <- atomically $ dupTChan (bft^.deltaOut) 74 | 75 | -- fork a thread to read the deltas from the noisefunge thread and 76 | -- write them to the ALSA output thread. 77 | void . forkIO $ forever . atomically $ do 78 | (b, prs, _, _) <- readTChan delts 79 | forM_ prs $ \(_, _, delt) -> do 80 | let evs = delt^.events 81 | forM_ evs $ \ev -> do 82 | case ev of 83 | NoteEvent n -> writeTChan (alsa^.outEvents) (b, n) 84 | _ -> return () 85 | return nfe 86 | 87 | type BeatState = S.StateT Beat 88 | 89 | beatStateHandler :: (Functor m, MonadIO m) => TVar Beat -> 90 | (STM Beat -> BeatState m Beat) -> m () 91 | beatStateHandler bvar f = do 92 | start <- liftIO . atomically $ readTVar bvar 93 | flip S.evalStateT start . void . forever $ do 94 | prev <- S.get 95 | let handler = do 96 | bv <- readTVar bvar 97 | if bv == prev then retry else return bv 98 | f handler >>= S.put 99 | 100 | -- beatEvents takes a NoiseFungeEngine and a handler function and calls 101 | -- the handler when the clock triggers a beat event. 102 | beatEvents :: (Functor m, MonadIO m) => NoiseFungeEngine -> 103 | (Beat -> [(PID, ProcessState, Delta)] -> 104 | [(PID, Maybe String)] -> [String] -> [BefungeStats] -> m a) -> m () 105 | beatEvents nfe fn = bev where 106 | bv = nfe^.beatVar 107 | dout = nfe^.funger.deltaOut 108 | eout = nfe^.funger.errOut 109 | bev = beatStateHandler bv $ \nextBeat -> do 110 | (curr, delts, deads, errs, stats) <- liftIO . atomically $ do 111 | bt <- nextBeat 112 | (delts, deads, stats) <- getDeltas bt 113 | errs <- getErrs 114 | return (bt, delts, deads, errs, stats) 115 | void . lift $ fn curr delts deads errs stats 116 | return curr 117 | getDeltas bt = do 118 | (bt', _, _, _) <- peekTChan dout 119 | if bt' > bt 120 | then return ([], [], []) 121 | else do 122 | (_, delts, dead, stats) <- readTChan dout 123 | ((delts, dead, stats) <>) <$> getDeltas bt 124 | getErrs = do 125 | emp <- isEmptyTChan eout 126 | if emp 127 | then return [] 128 | else (:) <$> readTChan eout <*> getErrs 129 | 130 | -- StartProgram is used to send a program to the NoiseFungeEngine 131 | startProgram :: NoiseFungeEngine -> ProgArray -> String -> String -> 132 | String -> IO PID 133 | startProgram nfe arr name inbuf outbuf = do 134 | mv <- newEmptyMVar 135 | atomically $ writeTChan (nfe^.funger.commIn) $ 136 | AddProcess arr name inbuf outbuf (Just mv) 137 | takeMVar mv 138 | 139 | -- StopProgram kills noisefunge programs based on PID or name. 140 | stopProgram :: NoiseFungeEngine -> Maybe Word32 -> Maybe String -> 141 | Maybe String -> IO () 142 | stopProgram nfe pf nf r = do 143 | atomically $ writeTChan (nfe^.funger.commIn) $ 144 | KillProcess filt r 145 | where filt (pid, nam) = fromJust (checkPid pid <|> checkNam nam <|> Just True) 146 | checkPid pid = (pid ==) <$> pf 147 | checkNam nam = (nam ==) <$> nf 148 | 149 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NoiseFunge (legacy) 2 | 3 | This is the original implementation of Noisefunge in haskell. Development has 4 | moved to the rust implementation: https://github.com/revnull/noisefunge.rs 5 | 6 | 7 | NoiseFunge is an obfuscated language for music livecoding. It is a member of 8 | the befunge family of languages. Some features of the language are: 9 | 10 | - Terse, visually striking syntax. 11 | - Animation of running programs. 12 | - MIDI support (ALSA). 13 | - A lightweight VM capable of supporting thousands of threads. 14 | - Network-based runtime control. 15 | 16 | Here's an example noisefunge video: https://www.youtube.com/watch?v=9zObiWi4Mbw 17 | 18 | ## Installation 19 | 20 | Currently, the recommended method for installing NoiseFunge is to use cabal 21 | to install the executable into a sandbox. The following steps can be used to 22 | install NoiseFunge. However, this method may still require installation of 23 | system packages for alsa and ncurses. 24 | 25 | ``` 26 | git clone https://github.com/revnull/noisefunge.git 27 | 28 | cd noisefunge 29 | 30 | cabal sandbox init 31 | cabal build 32 | cabal install 33 | ``` 34 | 35 | ## Executables 36 | 37 | If NoiseFunge is installed in a cabal sandbox, then the `noisefunge.env` file 38 | can be used to add the executables to the PATH and configure environmental 39 | variables for communicating with a running NoiseFunge program over the loopback 40 | network (port 4545). 41 | 42 | ### funged 43 | 44 | This is the NoiseFunge runtime daemon. It requires a config file specifying 45 | the tempo and network interfaces. An example named `test.cfg` is provided 46 | in the source repository. 47 | 48 | ### nfops 49 | 50 | This program lists all of the operators built in to NoiseFunge. 51 | 52 | ### nfloader 53 | 54 | This program loads a NoiseFunge file into the VM. The required command line 55 | parameters are a filename, and names of input and output buffers. 56 | 57 | ### nfkill 58 | 59 | This program kills a NoiseFunge process in the VM. There are three ways to run 60 | this. 61 | 62 | - `nfkill` kills all processes 63 | - `nfkill -n FILENAME` kills all processes matching the given filename 64 | - `nfkill -p PID` kills the process with the specified PID 65 | 66 | ### nftop 67 | 68 | This is the "top-like" program for inspecting the VM. 69 | 70 | - `q` or `Q` to quit. 71 | 72 | ### nfviewer 73 | 74 | This is the process animator. The only controls are: 75 | 76 | - `r` or `R` to re-tile the processes. 77 | - `q` or `Q` to quit. 78 | 79 | ## NoiseFunge opcodes 80 | 81 | The NoiseFunge VM supports several opcodes that are not standard in befunge-98. 82 | 83 | ### A-F 84 | 85 | NoiseFunge supports opcodes for A-F that work like the 0-9 opcodes but push the 86 | corresponding hex values onto the stack. 87 | 88 | ### Fork 89 | 90 | The `K` opcode forks a new process. The number 0 is pushed onto the parent's 91 | stack and 1 is pushed onto the child's stack. 92 | 93 | ### Call 94 | 95 | The `c` opcode is similar to the `g` opcode, but instead of accessing a byte 96 | from memory and pushing it onto the stack, the `c` opcode instead executes 97 | that byte as an opcode. 98 | 99 | ### Execute 100 | 101 | The `e` opcode pops a value off of the stack and executes it as an opcode. 102 | 103 | ### I/O and buffers 104 | 105 | NoiseFunge utilizes a non-standard form of input and output. Each process is 106 | assigned to one input buffer and one output buffer. Opcodes can be used to 107 | read and write from these buffers. Each process also has its own text buffer 108 | for writing characters and numbers. 109 | 110 | - `~` reads a byte from the input buffer and pushes it onto the stack. This 111 | blocks if there is no process writing to the buffer. 112 | - `.` pops a byte from the stack and writes it to the output buffer. This 113 | blocks if there is no process reading from the buffer. 114 | - `;` pops a byte from the stack and sends it to all processes waiting on the 115 | output buffer. This does not block. 116 | - `,` pops a byte and writes it to the text buffer. 117 | - `&` pops a byte and outputs it as a base 10 number to the text buffer. 118 | 119 | ### Note buffer opcodes 120 | 121 | The note buffer is a virtual device that can be read, written, or played 122 | through the use of opcodes. 123 | 124 | - `z` pops duration, velocity, pitch, and channel and writes them to the note 125 | buffer. 126 | - `Z` plays the note in the note buffer. 127 | - `y` pops a value off of the stack and sets the notebuf channel. 128 | - `Y` reads the channel from the notebuf and pushes it to the stack. 129 | - `x` pops a value off of the stack and sets the notebuf pitch. 130 | - `X` reads the pitch from the notebuf and pushes it to the stack. 131 | - `w` pops a value off of the stack and sets the notebuf velocity. 132 | - `W` reads the velocity from the notebuf and pushes it to the stack. 133 | - `u` pops a value off of the stack and sets the notebuf duration. 134 | - `U` reads the duration from the notebuf and pushes it to the stack. 135 | 136 | ### Conditional trampoline 137 | 138 | - `'` pops a value and jumps over the next opcode iff the value is 0. 139 | 140 | ### Quantize and sleep 141 | 142 | - `q` sleeps until the next beat is reached. 143 | - `Q` pops a value and sleeps until a beat divisible by the popped number. 144 | - `s` pops a number and sleeps for that many subbeats. 145 | 146 | ### User-defined opcodes 147 | 148 | The `[` opcode work similar to the quote operator. `[` causes bytes to 149 | be pushed onto a "function definition stack". Another `[` pops the first 150 | value off of the function definition stack and uses this as the name of the 151 | opcode being defined. The rest of the items in the stack become the opcodes 152 | used by the function *in the order they are popped off of the stack*. 153 | 154 | Some examples: 155 | 156 | - `[x*5Cc[` defines the opcode `c` that writes middle C to the note buffer 157 | - `[*:p[` defines the opcode `p` that squares the top value on the stack 158 | 159 | Function definition is global. A function defined in one thread will be 160 | visible to another thread. This can lead to interesting behavior when 161 | multiple threads are rewring a function. This also makes functions another 162 | type of IPC supported by NoiseFunge. 163 | 164 | The semantics of this feature are pretty poorly thought out and some 165 | combinations may lead to bizarre or unpredictable behavior. Some notes are 166 | listed below. 167 | 168 | - Opcode definitions are computed as soon as the second `[` is encountered. At 169 | this point, the opcode is defined based on the function of the opcodes at the 170 | point when it is defined. 171 | - User-defined opcodes execute in a single clock tick. Exceptions are opcodes 172 | that utilize the quantize/sleep opcodes: `q`, `Q`, and `s`. 173 | - `'` and `#` will take effect at the end of the execution of the opcode. 174 | - Builtin opcodes can be overwritten for exciting results. 175 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Server/Comm.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | {-# LANGUAGE FlexibleContexts #-} 20 | 21 | module Language.NoiseFunge.Server.Comm (Subscription(..), 22 | Request(..), 23 | Response(..), 24 | withAPIConnection, 25 | Conn, 26 | addProgram, 27 | sendBinary', 28 | requestReset, 29 | streamEvents) where 30 | 31 | import Control.Applicative 32 | import Control.Monad 33 | import qualified Control.Monad.State as ST 34 | import Control.Monad.Trans 35 | import Control.Monad.Trans.Maybe 36 | 37 | import Data.Binary 38 | import Data.ByteString.Lazy as BS 39 | 40 | import Network.Socket 41 | import Network.Socket.ByteString 42 | 43 | import System.Environment 44 | import System.Timeout 45 | 46 | import Language.NoiseFunge.Beat 47 | import Language.NoiseFunge.Befunge 48 | import Language.NoiseFunge.Befunge.Process 49 | 50 | 51 | data Subscription = Stats | Deltas 52 | deriving (Read, Show, Eq, Ord) 53 | 54 | instance Binary Subscription where 55 | get = getSub <$> getWord8 where 56 | getSub 0 = Stats 57 | getSub 1 = Deltas 58 | getSub _ = error "Bad Subscription" 59 | put Stats = putWord8 0 60 | put Deltas = putWord8 1 61 | 62 | data Request = 63 | Subscribe Subscription (Maybe Beat) 64 | | StartProgram String String String ProgArray 65 | | StopProgram (Maybe Word32) (Maybe String) (Maybe String) 66 | | SendReset 67 | deriving (Show, Eq, Ord) 68 | 69 | instance Binary Request where 70 | get = getWord8 >>= getReq where 71 | getReq 0 = Subscribe <$> get <*> get 72 | getReq 1 = StartProgram <$> get <*> get <*> get <*> get 73 | getReq 2 = StopProgram <$> get <*> get <*> get 74 | getReq 3 = return SendReset 75 | getReq _ = error "Bad request" 76 | put (Subscribe s b) = 77 | putWord8 0 >> put s >> put b 78 | put (StartProgram n ib ob a) = 79 | putWord8 1 >> put n >> put ib >> put ob >> put a 80 | put (StopProgram p n r) = 81 | putWord8 2 >> put p >> put n >> put r 82 | put SendReset = 83 | putWord8 3 84 | 85 | data Response = 86 | Catchup !Beat !PID ProgArray Delta 87 | | Change !Beat !PID Delta 88 | | Dead !Beat !PID (Maybe String) 89 | | NewProcess !PID 90 | | NextBeat !Beat 91 | | ProcessStats !Beat !BefungeStats 92 | | TickStats !Beat !Word32 !Word32 !Word32 !Word32 93 | | Reset 94 | deriving (Show, Eq, Ord) 95 | 96 | instance Binary Response where 97 | get = getWord8 >>= getResp where 98 | getResp 0 = Catchup <$> get <*> get <*> get <*> get 99 | getResp 1 = Change <$> get <*> get <*> get 100 | getResp 2 = Dead <$> get <*> get <*> get 101 | getResp 3 = NewProcess <$> get 102 | getResp 4 = NextBeat <$> get 103 | getResp 5 = ProcessStats <$> get <*> get 104 | getResp 6 = TickStats <$> get <*> get <*> get <*> get <*> get 105 | getResp 7 = return Reset 106 | getResp _ = error "Bad Response" 107 | put (Catchup a b c d) = putWord8 0 >> put a >> put b >> put c >> put d 108 | put (Change a b c) = putWord8 1 >> put a >> put b >> put c 109 | put (Dead a b c) = putWord8 2 >> put a >> put b >> put c 110 | put (NewProcess a) = putWord8 3 >> put a 111 | put (NextBeat a) = putWord8 4 >> put a 112 | put (ProcessStats a b) = putWord8 5 >> put a >> put b 113 | put (TickStats a b c d e) = 114 | putWord8 6 >> put a >> put b >> put c >> put d >> put e 115 | put Reset = putWord8 7 116 | 117 | data Conn = Conn Socket SockAddr 118 | 119 | withAPIConnection :: (Conn -> IO a) -> IO () 120 | withAPIConnection fn = do 121 | host <- getEnv "NOISEFUNGE_HOST" 122 | servHost <- getEnv "NOISEFUNGE_SERVER_HOST" 123 | servPort <- getEnv "NOISEFUNGE_SERVER_PORT" 124 | ais <- getAddrInfo Nothing (Just host) Nothing 125 | sais <- getAddrInfo Nothing (Just servHost) (Just servPort) 126 | case (ais, sais) of 127 | ([],__) -> error "Invalid NOISEFUNGE_HOST" 128 | (_, []) -> error 129 | "Invalid NOISEFUNGE_SERVER_HOST or NOISEFUNGE_SERVER_PORT" 130 | ((ai:_), (sai:_)) -> do 131 | s <- socket (addrFamily ai) Datagram defaultProtocol 132 | bind s (addrAddress ai) 133 | void $ fn (Conn s (addrAddress sai)) 134 | 135 | runBuffered :: Monad m => ST.StateT [b] m a -> m a 136 | runBuffered bst = ST.evalStateT bst [] 137 | 138 | sendBinary :: (MonadIO m, Functor m) => Binary b => 139 | b -> Conn -> ST.StateT [b1] m () 140 | sendBinary b (Conn s dest) = do 141 | let b' = toStrict $ encode b 142 | void $ liftIO $ sendTo s b' dest 143 | 144 | sendBinary' :: Binary b => b -> Conn -> IO () 145 | sendBinary' b (Conn s dest) = do 146 | let b' = toStrict $ encode b 147 | void $ sendTo s b' dest 148 | 149 | waitForBinary :: (Functor m, MonadIO m) => Binary b => Conn -> 150 | Maybe Int -> ST.StateT [b] m (Maybe b) 151 | waitForBinary (Conn s _) timeo = runMaybeT readBinary where 152 | readBinary = readFromBuf <|> readFromSock 153 | readFromBuf = do 154 | buff <- lift $ ST.get 155 | case buff of 156 | [] -> fail "empty" 157 | (x:xs) -> do 158 | ST.put xs 159 | return x 160 | readFromSock = do 161 | (bs, _) <- case timeo of 162 | Just t -> MaybeT . liftIO . timeout t $ recvFrom s 32768 163 | Nothing -> liftIO $ recvFrom s 32768 164 | lift $ decodeAll (fromChunks [bs]) 165 | readBinary 166 | 167 | decodeAll bs 168 | | BS.null bs = return () 169 | | otherwise = case (decodeOrFail bs) of 170 | Left (_,_,err) -> fail err 171 | Right (rest,_,a) -> do 172 | decodeAll rest 173 | ST.modify (a:) 174 | 175 | addProgram :: Conn -> String -> String -> String -> [String] -> IO PID 176 | addProgram conn name inbuf outbuf arr = do 177 | runBuffered $ do 178 | sendBinary (StartProgram name inbuf outbuf (makeProgArray arr)) conn 179 | Just (NewProcess p) <- waitForBinary conn Nothing 180 | return p 181 | 182 | requestReset :: Conn -> IO () 183 | requestReset conn = runBuffered $ do 184 | sendBinary SendReset conn 185 | 186 | streamEvents :: (Functor m, MonadIO m) => [Subscription] -> Conn -> 187 | (Response -> m a) -> m () 188 | streamEvents subs conn fn = runBuffered $ initialize where 189 | initialize = do 190 | subscribe Nothing 191 | wait 192 | subscribe b = do 193 | forM_ subs $ \sub -> do 194 | sendBinary (Subscribe sub b) conn 195 | wait = waitForBinary conn (Just 1000000) >>= handle 196 | handle Nothing = initialize 197 | handle (Just r@(NextBeat b)) = do 198 | void . lift $ fn r 199 | subscribe (Just b) 200 | wait 201 | handle (Just r) = do 202 | void . lift $ fn r 203 | wait 204 | 205 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Befunge/Process.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | module Language.NoiseFunge.Befunge.Process (ProgArray, makeProgArray, 23 | Dir(..), PC(PC), 24 | Event(..), 25 | pos, dir, Pos, 26 | Delta(..), oldpc, newpc, 27 | change, events, 28 | ProcessState, makeProcessState, 29 | Stack, pop, (#+), stackLength, 30 | mem, pc, stack, quote, 31 | jump, progIn, progOut, 32 | fnStack, 33 | noteBuf, ticks, 34 | OperatorParams(..), 35 | Fungine, FungeVM, 36 | FungeProcess, FungeProgram, 37 | Deltas, ProcessStats, 38 | psTicks, psStackSize, 39 | psQuote, 40 | Operator(..), 41 | opCode, opChar, 42 | opName, opDesc, 43 | OpSet(..), 44 | processStats, 45 | tellDelta, tellMem 46 | ) where 47 | 48 | import Control.Lens 49 | import Control.Monad 50 | import Control.Monad.RWS 51 | 52 | import qualified Data.Array as Arr 53 | import Data.Array.Unboxed 54 | import qualified Data.Binary as B 55 | import Data.Char 56 | import Data.Default 57 | import Data.Word 58 | 59 | import Language.NoiseFunge.Befunge.VM 60 | import Language.NoiseFunge.Note 61 | 62 | -- This module builds upon the VM code to generate processes that are distinct 63 | -- to the noisefunge engine. This provides the underlying functionality that 64 | -- the operators are built around. It includes things such as the program 65 | -- counter, stack, and process memory. 66 | 67 | type Pos = (Word8, Word8) 68 | 69 | type ProgArray = UArray Pos Word8 70 | 71 | -- Convert a list of lines into a program array. The height will be the number 72 | -- of lines and the width will be the length of the longest line. 73 | makeProgArray :: [String] -> ProgArray 74 | makeProgArray strs = arr where 75 | rows = fromIntegral $ length strs 76 | cols = fromIntegral $ maximum $ fmap length strs 77 | bnds = ((0,0), (rows-1, cols-1)) 78 | arr = array bnds $ do 79 | (r, row) <- zip [0..] strs 80 | (c, char) <- zip [0..cols-1] (row ++ pad) 81 | return ((r,c), fromIntegral $ ord char) 82 | pad = repeat ' ' 83 | 84 | data Dir = U | D | L | R 85 | deriving (Read, Show, Eq, Ord, Enum) 86 | 87 | instance B.Binary Dir where 88 | get = (toEnum . fromIntegral) <$> B.getWord8 89 | put = B.putWord8 . fromIntegral . fromEnum 90 | 91 | data PC = PC { 92 | _pos :: !Pos, 93 | _dir :: !Dir 94 | } deriving (Read, Show, Eq, Ord) 95 | 96 | instance Default PC where 97 | def = PC (0,0) R 98 | 99 | instance B.Binary PC where 100 | get = PC <$> B.get <*> B.get 101 | put (PC p d) = B.put p >> B.put d 102 | 103 | data Event = 104 | StringEvent String 105 | | ErrorEvent String 106 | | NoteEvent !Note 107 | deriving (Read, Show, Eq, Ord) 108 | 109 | instance B.Binary Event where 110 | get = B.getWord8 >>= getEv where 111 | getEv 0 = StringEvent <$> B.get 112 | getEv 1 = ErrorEvent <$> B.get 113 | getEv 2 = NoteEvent <$> B.get 114 | getEv _ = error "Bad event" 115 | put (StringEvent s) = B.putWord8 0 >> B.put s 116 | put (ErrorEvent s) = B.putWord8 1 >> B.put s 117 | put (NoteEvent n) = B.putWord8 2 >> B.put n 118 | 119 | -- A delta expresses how a process has changed in the last tick. 120 | data Delta = Delta { 121 | _oldpc :: Maybe PC, 122 | _newpc :: Maybe PC, 123 | _change :: Maybe ProgArray, 124 | _events :: [Event] 125 | } deriving (Show, Eq, Ord) 126 | 127 | instance Semigroup Delta where 128 | (<>) = mappend 129 | 130 | instance Monoid Delta where 131 | mempty = Delta Nothing Nothing Nothing [] 132 | mappend (Delta op1 np1 c1 e1) (Delta op2 np2 c2 e2) = 133 | Delta (op1 `mplus` op2) (np2 `mplus` np1) 134 | (c2 `mplus` c1) (e1 `mappend` e2) 135 | 136 | instance B.Binary Delta where 137 | get = Delta <$> B.get <*> B.get <*> B.get <*> B.get 138 | put (Delta a b c d) = B.put a >> B.put b >> B.put c >> B.put d 139 | 140 | instance Default Delta where 141 | def = mempty 142 | 143 | type Deltas s = [(PID, s, Delta)] -> [(PID, s, Delta)] 144 | 145 | data Stack a = Stack !Word32 [a] 146 | deriving (Read, Show, Eq, Ord) 147 | 148 | instance Semigroup (Stack a) where 149 | (<>) = mappend 150 | 151 | instance Monoid (Stack a) where 152 | mempty = Stack 0 [] 153 | mappend (Stack xl xs) (Stack yl ys) = Stack (xl + yl) (xs ++ ys) 154 | 155 | (#+) :: a -> Stack a -> Stack a 156 | a #+ Stack l xs = Stack (l+1) (a:xs) 157 | 158 | pop :: Stack a -> Maybe (a, Stack a) 159 | pop (Stack 0 []) = Nothing 160 | pop (Stack 0 _) = error "Invalid stack length" 161 | pop (Stack _ []) = error "Invalid stack contents" 162 | pop (Stack l (x:xs)) = Just (x, Stack (l-1) xs) 163 | 164 | stackLength :: Stack a -> Word32 165 | stackLength (Stack l _) = l 166 | 167 | data ProcessState = PS { 168 | _mem :: !ProgArray, 169 | _ticks :: !Word32, 170 | _pc :: !PC, 171 | _stack :: !(Stack Word8), 172 | _quote :: !Bool, 173 | _jump :: !Bool, 174 | _fnStack :: !(Maybe [Word8]), 175 | _progIn :: !String, -- Name of input buffer 176 | _progOut :: !String, -- Name of output buffer 177 | _noteBuf :: !(Maybe Note) 178 | } 179 | 180 | makeProcessState :: ProgArray -> String -> String -> ProcessState 181 | makeProcessState arr inp outp = 182 | PS arr 0 def mempty False False mempty inp outp Nothing 183 | 184 | -- OperatorParams provides some options for how noisefunge operators should 185 | -- behave. 186 | data OperatorParams = OperatorParams { 187 | haltOnError :: !Bool, 188 | wrapOnEdge :: !Bool, 189 | debugLogging :: !Bool 190 | } deriving (Read, Show, Eq, Ord) 191 | 192 | instance Default OperatorParams where 193 | def = OperatorParams True False False 194 | 195 | data Operator = Operator { 196 | _opName :: String, 197 | _opChar :: Char, 198 | _opDesc :: String, 199 | _opCode :: (Fungine ()) 200 | } 201 | 202 | newtype OpSet = OpSet { getOpSet :: Arr.Array Word8 (Maybe (Fungine ())) } 203 | 204 | type FungeRWS = RWS OperatorParams (Deltas ProcessState) OpSet 205 | 206 | type Fungine = ProcessStateT Word8 ProcessState FungeRWS 207 | 208 | type FungeVM = VM Word8 ProcessState FungeRWS 209 | 210 | type FungeProcess = Process Word8 ProcessState FungeRWS 211 | 212 | type FungeProgram = Program Word8 ProcessState FungeRWS 213 | 214 | $(makeLenses ''ProcessState) 215 | $(makeLenses ''Delta) 216 | $(makeLenses ''PC) 217 | $(makeLenses ''Operator) 218 | 219 | tellDelta :: Delta -> Fungine () 220 | tellDelta d = do 221 | pid <- getPID 222 | st <- getProcessState 223 | tell ((pid, st, d):) 224 | 225 | tellMem :: Fungine () 226 | tellMem = do 227 | arr <- use mem 228 | tellDelta $ Delta Nothing Nothing (Just arr) [] 229 | 230 | data ProcessStats = PStats { 231 | _psTicks :: !Word32, 232 | _psStackSize :: !Word32, 233 | _psQuote :: !Bool 234 | } deriving (Show, Eq, Ord) 235 | 236 | $(makeLenses ''ProcessStats) 237 | 238 | instance B.Binary ProcessStats where 239 | get = PStats <$> B.get <*> B.get <*> B.get 240 | put (PStats a b c) = B.put a >> B.put b >> B.put c 241 | 242 | processStats :: Getter ProcessState ProcessStats 243 | processStats = to processStats' where 244 | processStats' ps = PStats (ps^.ticks) (stackLength $ ps^.stack) 245 | (ps^.quote ) 246 | 247 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Server.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | module Language.NoiseFunge.Server (runServer, ServerConfig(..)) where 23 | 24 | import Network.Socket 25 | import Network.Socket.ByteString 26 | 27 | import Control.Concurrent 28 | import Control.Concurrent.STM 29 | 30 | import Control.Monad 31 | import qualified Control.Monad.State as ST 32 | import Control.Monad.Writer 33 | 34 | import Control.Lens 35 | 36 | import Data.Binary 37 | import Data.Int 38 | import qualified Data.Map as M 39 | import qualified Data.Set as S 40 | import Data.ByteString.Lazy as BSL hiding (readFile) 41 | import qualified Data.ByteString as BS 42 | 43 | import System.IO 44 | 45 | import Language.NoiseFunge.ALSA 46 | import Language.NoiseFunge.Beat 47 | import Language.NoiseFunge.Befunge 48 | import Language.NoiseFunge.Befunge.VM 49 | import Language.NoiseFunge.Befunge.Process 50 | import Language.NoiseFunge.Engine 51 | import Language.NoiseFunge.Server.Comm 52 | 53 | data ServerConfig = ServerConfig { 54 | _serverHosts :: [(Family, SockAddr)], 55 | _serverALSAConfig :: ALSAThreadConfig, 56 | _serverVMOptions :: OperatorParams, 57 | _serverPreload :: [(FilePath, String, String)], 58 | _serverPacketSize :: Word16 59 | } deriving (Show, Eq, Ord) 60 | 61 | $(makeLenses ''ServerConfig) 62 | 63 | type Subscriptions = M.Map Beat (S.Set SockAddr) 64 | 65 | data BinBuffer = BB { 66 | _currBuff :: (Int64, ByteString), 67 | _buffered :: [BS.ByteString] -> [BS.ByteString] 68 | } 69 | 70 | $(makeLenses ''BinBuffer) 71 | 72 | bufferBinary :: Binary b => Word16 -> [b] -> [BS.ByteString] 73 | bufferBinary ms xs = bufs $ ST.execState (buffer >> flush) initial where 74 | initial = BB blank id 75 | ms' = fromIntegral ms 76 | blank = (0, mempty) 77 | buffer = forM_ xs $ \x -> do 78 | let enc = encode x 79 | len = BSL.length enc 80 | bl <- use (currBuff._1) 81 | when (bl > 0 && (bl + len) > ms') $ flush 82 | zoom currBuff $ do 83 | _1 += len 84 | _2 %= (`mappend` enc) 85 | flush = do 86 | curr <- use currBuff 87 | case curr of 88 | (0, _) -> return () 89 | (_, bs) -> do 90 | buffered %= (. (toStrict bs:)) 91 | currBuff .= blank 92 | bufs bb = (bb^.buffered) [] 93 | 94 | requestHandler :: Socket -> NoiseFungeEngine -> TVar Bool -> 95 | TVar Subscriptions -> TVar Subscriptions -> IO () 96 | requestHandler s nfe rstv stats delts = forever $ do 97 | (bs, addr) <- recvFrom s 32768 98 | case decodeOrFail (fromChunks [bs]) of 99 | (Left (_,_,str)) -> hPutStrLn stderr ("Bad request: " ++ str) 100 | (Right (_,_, Subscribe sub b)) -> atomically $ do 101 | bt <- case b of 102 | Just b' -> return b' 103 | Nothing -> readTVar (nfe^.beatVar) 104 | let subs = case sub of 105 | Stats -> stats 106 | Deltas -> delts 107 | altfn = (Just . maybe (S.singleton addr) (S.insert addr)) 108 | modifyTVar subs (M.alter altfn bt) 109 | (Right (_,_, StartProgram n ib ob a)) -> do 110 | pid <- startProgram nfe a n ib ob 111 | hPutStrLn stderr ("Starting program: " ++ show pid) 112 | let res = toStrict $ encode $ NewProcess pid 113 | void $ sendTo s res addr 114 | (Right (_,_, StopProgram pf nf r)) -> do 115 | stopProgram nfe pf nf r 116 | hPutStrLn stderr ("Stopping Program(s): " ++ show (pf, nf, r)) 117 | (Right (_,_, SendReset)) -> do 118 | atomically $ writeTVar rstv True 119 | 120 | runServer :: ServerConfig -> IO () 121 | runServer conf = do 122 | hSetBuffering stderr LineBuffering 123 | let nextB = ((aconf^.alsaTempo) ##) 124 | bufferB = bufferBinary (conf^.serverPacketSize) 125 | aconf = conf^.serverALSAConfig 126 | nfe <- initNF aconf (conf^.serverVMOptions) 127 | rstv <- newTVarIO True 128 | servs <- forM (conf^.serverHosts) $ \(fam, addr) -> do 129 | s <- socket fam Datagram defaultProtocol 130 | bind s addr 131 | stats <- newTVarIO M.empty 132 | delts <- newTVarIO M.empty 133 | void . forkIO $ requestHandler s nfe rstv stats delts 134 | return (s, stats, delts) 135 | forM_ (conf^.serverPreload) $ \(f, ib, ob) -> do 136 | pa <- (makeProgArray . lines) <$> (liftIO $ readFile f) 137 | startProgram nfe pa f ib ob 138 | hPutStrLn stderr ("Server is running.") 139 | beatEvents nfe $ \bt delts deads _ stats -> do 140 | rst <- atomically $ do 141 | v <- readTVar rstv 142 | when v $ writeTVar rstv False 143 | return v 144 | let nb = toStrict $ encode $ NextBeat (nextB bt) 145 | forM_ servs $ \(s, ssubs, dsubs) -> do 146 | when rst $ do 147 | let rstm = toStrict $ encode Reset 148 | addrs <- atomically $ do 149 | daddrs <- M.elems <$> readTVar dsubs 150 | saddrs <- M.elems <$> readTVar ssubs 151 | return $ mconcat daddrs <> mconcat saddrs 152 | mapM_ (sendTo s rstm) (S.toList addrs) 153 | void $ forkIO $ do 154 | (outd, waiting) <- atomically $ do 155 | subs <- readTVar dsubs 156 | let (outd, waiting, rest) = M.splitLookup bt subs 157 | writeTVar dsubs rest 158 | return (mconcat (M.elems outd), waiting) 159 | let waiting' = maybe [] S.toList waiting 160 | outd' = S.toList outd 161 | 162 | forM_ waiting' $ \client -> do 163 | sendTo s nb client 164 | forM_ outd' $ \client -> do 165 | sendTo s nb client 166 | 167 | let changes = bufferB $ do 168 | (pid, _, d) <- delts 169 | return $ Change bt pid d 170 | catchus = bufferB $ do 171 | (pid, ps, d) <- delts 172 | return $ Catchup bt pid (ps^.mem) d 173 | forM_ changes $ \ch -> do 174 | forM_ waiting' $ \client -> do 175 | sendTo s ch client 176 | forM_ catchus $ \ch -> do 177 | forM_ outd' $ \client -> do 178 | sendTo s ch client 179 | 180 | let deads' = bufferB $ do 181 | (pid, r) <- deads 182 | return $ Dead bt pid r 183 | 184 | forM_ deads' $ \dead -> do 185 | forM_ waiting' $ \client -> do 186 | sendTo s dead client 187 | forM_ outd' $ \client -> do 188 | sendTo s dead client 189 | 190 | void $ forkIO $ do 191 | waiting <- atomically $ do 192 | subs <- readTVar ssubs 193 | let (outd, waiting, rest) = M.splitLookup bt subs 194 | writeTVar ssubs rest 195 | let waiting' = maybe S.empty id waiting 196 | return (S.toList $ mconcat (M.elems outd) <> waiting') 197 | 198 | forM_ waiting $ \client -> do 199 | sendTo s nb client 200 | 201 | let stats' = bufferB $ do 202 | stat <- stats 203 | return $ ProcessStats bt stat 204 | 205 | forM_ stats' $ \stat -> do 206 | forM_ waiting $ \client -> do 207 | sendTo s stat client 208 | 209 | let agg = toStrict $ encode $ TickStats bt run' rbl' wbl' ded' 210 | run' = getSum run 211 | rbl' = getSum rbl 212 | wbl' = getSum wbl 213 | ded' = getSum ded 214 | (run, rbl, wbl, ded) = execWriter $ do 215 | mapM_ (tell . addStat . (^.vmExec)) stats 216 | addStat ERunning = (Sum 1, mempty, mempty, mempty) 217 | addStat (EHalted _) = (mempty, mempty, mempty, Sum 1) 218 | addStat (ERBlock _) = (mempty, Sum 1, mempty, mempty) 219 | addStat (EWBlock _) = (mempty, mempty, Sum 1, mempty) 220 | 221 | forM_ waiting $ \client -> do 222 | sendTo s agg client 223 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/ALSA.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell #-} 21 | module Language.NoiseFunge.ALSA (startALSAThread, ALSAThread, 22 | ALSAPort(ALSAPort), portConnection, 23 | portStarting, 24 | ALSAThreadConfig(ALSAThreadConfig), 25 | alsaTempo, alsaPorts, 26 | tid, clock, inEvents, 27 | outEvents) where 28 | 29 | import Control.Concurrent 30 | import Control.Concurrent.STM 31 | import Control.Exception 32 | import Control.Lens 33 | import Control.Monad 34 | 35 | import Data.Array 36 | import qualified Data.Array.IO as IOArray 37 | import Data.Default 38 | import qualified Data.Map as M 39 | import Data.Monoid 40 | import Data.Ratio 41 | import Data.Word 42 | 43 | import qualified Sound.ALSA.Exception as Exc 44 | import qualified Sound.ALSA.Sequencer as Seq 45 | import qualified Sound.ALSA.Sequencer.Address as Addr 46 | import qualified Sound.ALSA.Sequencer.Client as Client 47 | import qualified Sound.ALSA.Sequencer.Connect as Conn 48 | import qualified Sound.ALSA.Sequencer.Event as Event 49 | import qualified Sound.ALSA.Sequencer.Port as Port 50 | import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo 51 | import qualified Sound.ALSA.Sequencer.Queue as Queue 52 | import qualified Sound.ALSA.Sequencer.Time as Time 53 | import qualified Sound.ALSA.Sequencer.RealTime as RealTime 54 | 55 | import Language.NoiseFunge.Beat 56 | import Language.NoiseFunge.Note 57 | 58 | import System.Environment 59 | import System.IO 60 | 61 | import Text.Printf 62 | 63 | data ALSAPort = ALSAPort { 64 | _portConnection :: Maybe String, 65 | _portStarting :: Word8 66 | } deriving (Show, Eq, Ord) 67 | 68 | $(makeLenses ''ALSAPort) 69 | 70 | data ALSAThread = ALSAThread { 71 | _tid :: ThreadId, 72 | _clock :: TVar Beat, 73 | _inEvents :: TChan (Beat, Note), 74 | _outEvents :: TChan (Beat, Note) 75 | } 76 | 77 | $(makeLenses ''ALSAThread) 78 | 79 | data ALSAThreadConfig = ALSAThreadConfig { 80 | _alsaTempo :: Tempo, 81 | _alsaPorts :: M.Map String ALSAPort, 82 | _alsaNoteLimiter :: Bool 83 | } deriving (Show, Eq, Ord) 84 | 85 | $(makeLenses ''ALSAThreadConfig) 86 | 87 | -- A note limiter prevents a note from playing when there is already a note 88 | -- playing for that channel and pitch 89 | type NoteLimiter = IOArray.IOArray Word8 (Maybe Beat) 90 | 91 | data NotePlayer = NotePlayer { 92 | _playerAddr :: Addr.T, 93 | _playerChannel :: Word8, 94 | _playerLimiter :: Maybe NoteLimiter 95 | } 96 | 97 | $(makeLenses ''NotePlayer) 98 | 99 | newNoteLimiter :: IO NoteLimiter 100 | newNoteLimiter = IOArray.newArray (0,255) Nothing 101 | 102 | -- checkOverlap returns True if there is overlap given the start, end, 103 | -- and pitch. Otherwise, it returns False and writes that note to the 104 | -- note limiter. 105 | -- checkOverlap :: Start -> End -> Pitch -> NoteLimiter -> IO Bool 106 | checkOverlap :: Beat -> Beat -> Word8 -> NoteLimiter -> IO Bool 107 | checkOverlap st en pch nl = do 108 | pl <- IOArray.readArray nl pch 109 | case fmap (> st) pl of 110 | Nothing -> IOArray.writeArray nl pch (Just en) >> return False 111 | Just False -> IOArray.writeArray nl pch (Just en) >> return False 112 | Just True -> return True 113 | 114 | beatTime :: Tempo -> Beat -> RealTime.T 115 | beatTime (Tempo tb ts) (Beat b s) = rt where 116 | perbeat :: Ratio Integer 117 | perbeat = 60 % (fromIntegral $ tb * ts) 118 | rt = RealTime.fromFractional (perbeat * bt) 119 | bt = (fromIntegral $ b * ts + s) % 1 120 | 121 | startALSAThread :: ALSAThreadConfig -> IO ALSAThread 122 | startALSAThread conf = do 123 | cl <- newTVarIO def 124 | nin <- newTChanIO 125 | nout <- newTChanIO 126 | let handler = alsaHandler conf cl nin nout 127 | th <- forkIO $ Seq.withDefault Seq.Block handler 128 | return $ ALSAThread th cl nin nout 129 | 130 | createPorts :: ALSAThreadConfig -> 131 | Seq.T Seq.DuplexMode -> Client.T -> Queue.T -> 132 | IO (Array Word8 [NotePlayer]) 133 | createPorts conf h c q = arrfn <$> portSets where 134 | ports = conf^.alsaPorts 135 | lim = conf^.alsaNoteLimiter 136 | arrfn = array (0, 255) . M.toList . 137 | M.unionWith (<>) blank . M.unionsWith (<>) 138 | blank = M.fromList [(i, []) | i <- [0..255]] 139 | portSets = forM (M.toList ports) $ \(name, port) -> do 140 | let minb = port^.portStarting 141 | ioport <- Port.createSimple h name 142 | (Port.caps [Port.capRead, Port.capSubsRead]) 143 | (Port.types [Port.typeMidiGeneric, Port.typeApplication]) 144 | PortInfo.modify h ioport $ do 145 | PortInfo.setTimestamping True 146 | PortInfo.setTimestampReal True 147 | PortInfo.setTimestampQueue q 148 | let conn = port^.portConnection 149 | flip Exc.catch (void . forkIO . badConn ioport conn) $ 150 | connectRemote ioport conn 151 | let addr = Addr.Cons c ioport 152 | players <- forM [0..15] $ \i -> do 153 | nl <- if lim 154 | then Just <$> newNoteLimiter 155 | else return Nothing 156 | return (i + minb, [NotePlayer addr i nl]) 157 | return $ M.fromList players 158 | connectRemote _ Nothing = return () 159 | connectRemote ioport (Just conn) = do 160 | remote <- Addr.parse h conn 161 | void $ Conn.createTo h ioport remote 162 | badConn _ Nothing _ = return () -- Should be unreachable 163 | badConn ioport jst@(Just conn) e = do 164 | hPutStrLn stderr $ printf "Error connecting to ALSA port: %s - %s" 165 | conn (show e) 166 | threadDelay 60000000 167 | handle (badConn ioport jst) $ 168 | connectRemote ioport jst 169 | 170 | alsaHandler :: ALSAThreadConfig -> TVar Beat -> 171 | TChan (Beat, Note) -> TChan (Beat, Note) -> Seq.T Seq.DuplexMode -> 172 | IO () 173 | alsaHandler conf clockv _ noteout h = do 174 | let tempo@(Tempo tb ts) = conf^.alsaTempo 175 | getProgName >>= Client.setName h 176 | 177 | c <- Client.getId h 178 | q <- Queue.alloc h 179 | 180 | ioports <- createPorts conf h c q 181 | 182 | priv <- Port.createSimple h "priv" 183 | (Port.caps [Port.capRead, Port.capWrite]) 184 | (Port.types [Port.typeMidiGeneric]) 185 | PortInfo.modify h priv $ do 186 | PortInfo.setTimestamping True 187 | PortInfo.setTimestampReal True 188 | PortInfo.setTimestampQueue q 189 | 190 | let praddr = Addr.Cons c priv 191 | ticktime = fromIntegral ((3000000000 :: Integer) `div` 192 | (fromIntegral (tb * ts))) 193 | timefn = Time.consAbs . Time.Real . beatTime tempo 194 | 195 | Queue.control h q (Event.QueueTempo (Event.Tempo ticktime)) Nothing 196 | Queue.control h q Event.QueueStart Nothing 197 | 198 | let echo bt@(Beat b s) = void . Event.output h $ (Event.simple praddr 199 | (Event.CustomEv Event.Echo $ Event.Custom b s 0)) { 200 | Event.time = timefn bt, 201 | Event.dest = praddr, 202 | Event.queue = q 203 | } 204 | let play addr b ev = void . Event.output h $ (Event.simple addr ev) { 205 | Event.time = timefn b, 206 | Event.dest = Addr.subscribers, 207 | Event.queue = q 208 | } 209 | let step = (tempo ##) 210 | 211 | let loopEvents = do 212 | notes <- atomically $ drainTChan noteout 213 | let notePlayers = do 214 | (b, n) <- notes 215 | p <- ioports ! (n^.channel) 216 | return (b, n, p) 217 | sendNotes <- forM notePlayers $ \(b@(Beat x y), n, player) -> do 218 | let addr = player^.playerAddr 219 | chan = player^.playerChannel 220 | lim = player^.playerLimiter 221 | pch = n^.pitch 222 | ne = Event.simpleNote (Event.Channel chan) 223 | (Event.Pitch pch) 224 | (Event.Velocity $ n^.velocity) 225 | nton = play addr b $ Event.NoteEv Event.NoteOn ne 226 | endBeat = Beat (x + fromIntegral (n^.duration)) y 227 | ntof = play addr endBeat $ 228 | Event.NoteEv Event.NoteOff ne 229 | overlap <- case lim of 230 | Nothing -> return False 231 | Just lim' -> checkOverlap b endBeat pch lim' 232 | if overlap 233 | then return [] 234 | else return [nton, ntof] 235 | sequence_ (concat sendNotes) 236 | _ <- Event.drainOutput h 237 | event <- Event.input h 238 | case Event.body event of 239 | Event.CustomEv Event.Echo (Event.Custom b s 0) -> do 240 | let next = step curr 241 | curr = (Beat b s) 242 | atomically $ writeTVar clockv curr 243 | echo next 244 | return () 245 | Event.ConnEv x y -> do 246 | hPutStrLn stderr $ printf "Connected: %s - %s" (show x) (show y) 247 | _ -> return () 248 | loopEvents 249 | echo def 250 | _ <- Event.outputPending h 251 | loopEvents 252 | 253 | drainTChan :: TChan a -> STM [a] 254 | drainTChan c = drainer where 255 | drainer = do 256 | empt <- isEmptyTChan c 257 | if empt then return [] else (:) <$> readTChan c <*> drainer 258 | 259 | -------------------------------------------------------------------------------- /nfviewer/nfviewer.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell, TupleSections, DeriveDataTypeable #-} 21 | 22 | import Prelude hiding (catch) 23 | 24 | import Control.Applicative 25 | import Control.Exception 26 | import Control.Lens 27 | import Control.Monad 28 | import qualified Control.Monad.State as S 29 | import Control.Monad.Trans 30 | 31 | import Data.Array.Unboxed 32 | import Data.Char 33 | import Data.IORef 34 | import qualified Data.Map as M 35 | import Data.Monoid 36 | import Data.Typeable 37 | import Data.Word 38 | 39 | import Options.Applicative hiding (str) 40 | 41 | import System.Random 42 | 43 | import UI.NCurses as Curses 44 | 45 | import Tiler 46 | import Language.NoiseFunge.API 47 | 48 | newtype Splitter = Splitter { unSplitter :: (Word32, Word32) } 49 | 50 | instance Read Splitter where 51 | readsPrec p = readParen (p > 7) 52 | (\r -> [(Splitter (x,y),u) | (x,s) <- readsPrec 8 r, 53 | ("/",t) <- lex s, 54 | (y,u) <- readsPrec 8 t ]) 55 | 56 | data ViewerOpts = ViewerOpts { 57 | _distributor :: Maybe Splitter 58 | } 59 | 60 | $(makeLenses ''ViewerOpts) 61 | 62 | optsSpec :: Parser ViewerOpts 63 | optsSpec = ViewerOpts 64 | <$> optional (option auto (long "distribution" <> short 'd')) 65 | 66 | desc :: InfoMod a 67 | desc = fullDesc 68 | <> header "nfviewer - noisefunge viewer" 69 | 70 | data ViewerState = ViewerState { 71 | _procs :: M.Map PID (Maybe (Tile, Window, Delta -> Curses ())), 72 | _tiler :: Tiler, 73 | _gen :: StdGen 74 | } 75 | 76 | $(makeLenses ''ViewerState) 77 | 78 | data TextBuf = TB ColorID Integer Window (IORef String) 79 | 80 | safeChars :: String -> String 81 | safeChars str = do 82 | c <- str 83 | if isPrint c 84 | then return c 85 | else return ' ' 86 | 87 | newTextBuf :: ColorID -> Integer -> Int -> Window -> IO TextBuf 88 | newTextBuf col row size win = 89 | TB col row win <$> newIORef (take size (repeat ' ')) 90 | 91 | putTextBuf :: TextBuf -> String -> Curses () 92 | putTextBuf (TB c r w s) st = do 93 | str <- liftIO $ readIORef s 94 | let st' = concatMap escape st 95 | str' = drop (length st') $ str ++ st' 96 | liftIO $ writeIORef s str' 97 | updateWindow w $ do 98 | moveCursor r 0 99 | setColor c 100 | drawString . safeChars $ str' 101 | where escape '\n' = "\\n" 102 | escape ch = [ch] 103 | 104 | highlight :: ProgArray -> Pos -> ColorID -> Update () 105 | highlight arr (r,c) col = do 106 | moveCursor (fromIntegral r + 1) (fromIntegral c) 107 | setColor col 108 | drawString . safeChars $ [chr . fromIntegral $ (arr ! (r, c))] 109 | 110 | drawBoard :: ProgArray -> Update () 111 | drawBoard arr = do 112 | let (_, (rm, cm)) = bounds arr 113 | moveCursor 1 0 114 | setColor defaultColorID 115 | forM_ [0..rm] $ \row -> do 116 | moveCursor (fromIntegral row + 1) 0 117 | let str = [chr . fromIntegral $ (arr ! (row, col)) | col <- [0..cm]] 118 | drawString . safeChars $ str 119 | 120 | newProgView :: ViewerOpts -> ColorID -> ColorID -> ColorID -> TextBuf -> 121 | PID -> ProgArray -> 122 | S.StateT ViewerState Curses (Maybe (Tile, Window, Delta -> Curses ())) 123 | newProgView opts hdr exec out tbe (pnum, pnam) parr = res where 124 | (_, (rm, cm)) = bounds parr 125 | rm' = fromIntegral rm 126 | cm' = fromIntegral cm 127 | filtn = fst . unSplitter <$> opts^.distributor 128 | filtd = snd . unSplitter <$> opts^.distributor 129 | filtf d n x = n == (x `mod` d) 130 | filt x = filtf <$> filtd <*> filtn <*> pure x 131 | res = do 132 | tilr <- use tiler 133 | tile' <- gen %%= tile 5 'x' (rm' + 3) (cm' + 2) tilr 134 | let valid = maybe True id (filt pnum) 135 | case (valid, tile') of 136 | (False, _) -> return Nothing 137 | (_, Nothing) -> return Nothing 138 | (_, Just (til@(Tile _ tl _), tilr')) -> do 139 | tiler .= tilr' 140 | (w, fn) <- lift (viewer tl) 141 | return $ Just (til, w, fn) 142 | viewer (r, c) = do 143 | w <- newWindow (rm' + 3) (cm' + 2) r c 144 | updateWindow w $ do 145 | moveCursor 0 0 146 | setColor hdr 147 | let hname = take (fromIntegral cm' + 1) (name ++ repeat ' ') 148 | name = show pnum ++ (':':pnam) 149 | drawString hname 150 | tb <- liftIO $ newTextBuf out (rm' + 2) (fromIntegral cm' + 1) w 151 | putTextBuf tb " " 152 | aref <- liftIO $ newIORef parr 153 | updateWindow w $ drawBoard parr 154 | return . (w,) $ \delt -> do 155 | arr <- liftIO $ readIORef aref 156 | arr' <- do 157 | forM_ (delt^.events) $ \ev -> case ev of 158 | StringEvent str -> putTextBuf tb str 159 | ErrorEvent e -> putTextBuf tbe e 160 | _ -> return () 161 | arr' <- case delt^.change of 162 | Nothing -> return arr 163 | Just arr' -> updateWindow w $ do 164 | drawBoard arr' 165 | return arr' 166 | updateWindow w $ do 167 | case delt^.oldpc of 168 | Nothing -> return () 169 | Just pc -> do 170 | highlight arr' (pc^.pos) defaultColorID 171 | case delt^.newpc of 172 | Nothing -> return () 173 | Just pc -> do 174 | highlight arr' (pc^.pos) exec 175 | 176 | return arr' 177 | 178 | liftIO $ writeIORef aref arr' 179 | 180 | clearWindow :: Tile -> Window -> Curses () 181 | clearWindow (Tile _ (r,c) (rx, cx)) w = updateWindow w $ do 182 | setColor defaultColorID 183 | let rm = rx - r 184 | st = [' ' | _ <- [c..cx - 1]] 185 | forM_ [0..rm] $ \row -> do 186 | moveCursor row 0 187 | drawString st 188 | 189 | data ViewerException = Redraw | Quit 190 | deriving (Show, Typeable) 191 | 192 | instance Exception ViewerException 193 | 194 | main :: IO () 195 | main = withAPIConnection $ \conn -> do 196 | let loop = mainCurses conn `catch` handler 197 | handler Redraw = loop 198 | handler Quit = return () 199 | loop 200 | 201 | getAllEvents :: Window -> Curses [Curses.Event] 202 | getAllEvents w = allEvs where 203 | allEvs = do 204 | ev <- getEvent w (Just 0) 205 | case ev of 206 | Nothing -> return [] 207 | Just ev' -> (ev':) <$> allEvs 208 | 209 | redraw :: S.StateT ViewerState Curses b 210 | redraw = do 211 | zoom (procs.traverse) $ do 212 | pr <- S.get 213 | lift $ case pr of 214 | Nothing -> return () 215 | Just (_, w, _) -> closeWindow w 216 | liftIO $ throwIO Redraw 217 | 218 | mainCurses :: Conn -> IO () 219 | mainCurses conn = do 220 | opts <- execParser (info (helper <*> optsSpec) desc) 221 | runCurses $ do 222 | setEcho False 223 | _ <- setCursorMode CursorInvisible 224 | w <- defaultWindow 225 | (r, c) <- screenSize 226 | 227 | updateWindow w $ do 228 | setColor defaultColorID 229 | let blank = take (fromIntegral $ c - 1) $ repeat ' ' 230 | forM_ [0..r-1] $ \y -> do 231 | moveCursor y 0 232 | drawString blank 233 | 234 | exec <- newColorID ColorBlack ColorWhite 1 235 | out <- newColorID ColorWhite ColorBlue 2 236 | err <- newColorID ColorWhite ColorRed 3 237 | hdr <- newColorID ColorBlack ColorCyan 4 238 | tbe <- liftIO $ newTextBuf err (r - 2) (fromIntegral c) w 239 | putTextBuf tbe " " 240 | 241 | let newView = newProgView opts hdr exec out tbe 242 | 243 | render 244 | 245 | vs <- ViewerState mempty (newTiler (r - 2) c) <$> liftIO newStdGen 246 | 247 | void $ flip S.runStateT vs $ streamEvents [Deltas] conn $ \ev -> do 248 | cevs <- lift $ getAllEvents w 249 | forM_ cevs $ \cev -> do 250 | case cev of 251 | EventResized -> redraw 252 | EventCharacter 'r' -> redraw 253 | EventCharacter 'R' -> redraw 254 | EventCharacter 'q' -> liftIO $ throwIO Quit 255 | EventCharacter 'Q' -> liftIO $ throwIO Quit 256 | _ -> return () 257 | case ev of 258 | NextBeat bt -> do 259 | lift $ updateWindow w $ do 260 | moveCursor (r-1) 0 261 | setColor defaultColorID 262 | drawString $ show bt 263 | Catchup _ pid arr delt -> do 264 | prc <- use (procs.(at pid)) 265 | case prc of 266 | Nothing -> do 267 | pv <- newView pid arr 268 | case pv of 269 | Nothing -> do 270 | procs.(at pid) .= Just Nothing 271 | pv'@(Just (_, _, fn)) -> do 272 | procs.(at pid) .= Just pv' 273 | lift $ fn delt 274 | Just Nothing -> return () 275 | Just (Just (_, _, fn)) -> 276 | lift $ fn delt 277 | Change _ pid delt -> do 278 | prc <- use (procs.(at pid)) 279 | case (prc, delt^.change) of 280 | (Nothing, Just ch) -> do 281 | pv <- newView pid ch 282 | case pv of 283 | Nothing -> procs.(at pid) .= Just Nothing 284 | pv'@(Just (_, _, fn)) -> do 285 | procs.(at pid) .= Just pv' 286 | lift $ fn delt 287 | (Nothing, _) -> do 288 | return () 289 | (Just Nothing, _) -> return () 290 | (Just (Just (_, _, fn)), _) -> 291 | lift $ fn delt 292 | return () 293 | Dead _ pid m -> do 294 | prc <- use (procs.(at pid)) 295 | case prc of 296 | Just (Just (t, w', _)) -> do 297 | lift $ clearWindow t w' 298 | procs.(at pid) .= Nothing 299 | tiler %= untile t 300 | lift $ closeWindow w' 301 | Just Nothing -> do 302 | procs.(at pid) .= Nothing 303 | _ -> return () 304 | case m of 305 | Nothing -> return () 306 | Just m' -> do 307 | lift $ putTextBuf tbe (show pid) 308 | lift $ putTextBuf tbe ":" 309 | lift $ putTextBuf tbe m' 310 | lift $ putTextBuf tbe "|" 311 | return () 312 | Reset -> redraw 313 | _ -> return () 314 | lift $ render 315 | 316 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Befunge/Operator.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE RankNTypes #-} 21 | 22 | module Language.NoiseFunge.Befunge.Operator (OperatorParams(..), 23 | move, getOp, runOp, quoteOp, 24 | fnStackOp, 25 | stdOps, 26 | operators, 27 | logError, logDebug 28 | ) where 29 | 30 | import Control.Lens 31 | import Control.Monad.RWS 32 | 33 | import qualified Data.Array as Arr 34 | import Data.Array.Unboxed 35 | import Data.Char 36 | import Data.Default 37 | import qualified Data.Map as M 38 | import Data.Word 39 | 40 | import System.Random 41 | 42 | import Language.NoiseFunge.Befunge.Process 43 | import Language.NoiseFunge.Befunge.VM 44 | import Language.NoiseFunge.Note 45 | import Language.NoiseFunge.Beat 46 | 47 | boundedStep :: (Word8, Word8) -> Int -> PC -> Either Pos Pos 48 | boundedStep (_, xm) s (PC (y, x) L) = 49 | let x' = fromIntegral x - s 50 | ov = fromIntegral (fromIntegral xm + 1 + x') 51 | in if x' < 0 then Left (y, ov) else Right (y, fromIntegral x') 52 | boundedStep (_, xm) s (PC (y, x) R) = 53 | let x' = fromIntegral x + s 54 | ov = fromIntegral (x' - fromIntegral xm - 1) 55 | in if x' > fromIntegral xm then Left (y, ov) else Right (y, fromIntegral x') 56 | boundedStep (ym, _) s (PC (y, x) U) = 57 | let y' = fromIntegral y - s 58 | ov = fromIntegral (fromIntegral ym + 1 + y') 59 | in if y' < 0 then Left (ov, x) else Right (fromIntegral y', x) 60 | boundedStep (ym, _) s (PC (y, x) D) = 61 | let y' = fromIntegral y + s 62 | ov = fromIntegral (y' - fromIntegral ym - 1) 63 | in if y' > fromIntegral ym then Left (ov, x) else Right (fromIntegral y', x) 64 | 65 | logDebug :: String -> Fungine () 66 | logDebug str = do 67 | deb <- asks debugLogging 68 | when deb . tellDelta $ def { _events = [ErrorEvent str] } 69 | 70 | logError :: String -> Fungine () 71 | logError str = tellDelta $ def { _events = [ErrorEvent str] } 72 | 73 | dieError :: String -> a -> Fungine a 74 | dieError str a = do 75 | hal <- asks haltOnError 76 | logError str 77 | if hal 78 | then die str >> return a 79 | else return a 80 | 81 | move :: Fungine () 82 | move = do 83 | j <- use jump 84 | sd <- if j 85 | then jump .= False >> return 2 86 | else return 1 87 | (_,bnds) <- bounds `fmap` use mem 88 | c@(PC _ d) <- use pc 89 | hal <- asks wrapOnEdge 90 | let p' = boundedStep bnds sd c 91 | p'' <- case (hal, p') of 92 | (True, Left p'') -> return p'' 93 | (True, Right p'') -> return p'' 94 | (False, Right p'') -> return p'' 95 | (False, Left p'') -> dieError "Exceeded memory bounds" p'' 96 | pc.pos .= p'' 97 | tellDelta $ def { _oldpc = Just c, _newpc = Just (PC p'' d) } 98 | 99 | quoteOp :: Word8 -> Fungine () 100 | quoteOp 0x22 = quote .= False 101 | quoteOp x = pushOp x 102 | 103 | fnStackOp :: Word8 -> Fungine () 104 | fnStackOp 0x5b = do 105 | Just ops <- use fnStack 106 | OpSet arr <- lift $ get 107 | case ops of 108 | (o:os) -> do 109 | let fun = foldr proc (Just $ return ()) os 110 | proc c n = do 111 | oper <- arr ! c 112 | n' <- n 113 | return $ oper >> n' 114 | case fun of 115 | Nothing -> dieError "Invalid opcode in function." () 116 | Just _ -> lift . put . OpSet $ (arr // [(o, fun)]) 117 | [] -> dieError "Empty function definition." () 118 | fnStack .= Nothing 119 | fnStackOp x = fnStack %= (fmap (x:)) 120 | 121 | pushOp :: Word8 -> Fungine () 122 | pushOp ch = do 123 | st <- use stack 124 | let sl = stackLength st 125 | when (sl > 1024) $ do 126 | dieError ("Large stack size: " ++ show sl) () 127 | stack %= (ch #+) 128 | 129 | popOp :: Fungine Word8 130 | popOp = do 131 | st <- use stack 132 | case pop st of 133 | Just (x, st') -> do 134 | stack .= st' 135 | return x 136 | Nothing -> do 137 | dieError "Pop from empty stack" 0 138 | 139 | getOp :: Fungine Word8 140 | getOp = do 141 | (PC (x,y) _) <- use pc 142 | let i = (fromIntegral x, fromIntegral y) 143 | (! i) `fmap` use mem 144 | 145 | stdOps :: M.Map Word8 Operator 146 | stdOps = M.fromList $ [ 147 | mkStdOp "NOP" ' ' "Do Nothing" $ return () 148 | , mkStdOp "Left" '<' "Change direction to left." $ do 149 | pc.dir .= L 150 | , mkStdOp "Right" '>' "Change direction to right." $ do 151 | pc.dir .= R 152 | , mkStdOp "Down" 'v' "Change direction to down." $ do 153 | pc.dir .= D 154 | , mkStdOp "Up" '^' "Change direction to up." $ do 155 | pc.dir .= U 156 | , mkStdOp "0" '0' "Push 0 onto the stack" $ 157 | pushOp 0 158 | , mkStdOp "1" '1' "Push 1 onto the stack" $ 159 | pushOp 1 160 | , mkStdOp "2" '2' "Push 2 onto the stack" $ 161 | pushOp 2 162 | , mkStdOp "3" '3' "Push 3 onto the stack" $ 163 | pushOp 3 164 | , mkStdOp "4" '4' "Push 4 onto the stack" $ 165 | pushOp 4 166 | , mkStdOp "5" '5' "Push 5 onto the stack" $ 167 | pushOp 5 168 | , mkStdOp "6" '6' "Push 6 onto the stack" $ 169 | pushOp 6 170 | , mkStdOp "7" '7' "Push 7 onto the stack" $ 171 | pushOp 7 172 | , mkStdOp "8" '8' "Push 8 onto the stack" $ 173 | pushOp 8 174 | , mkStdOp "9" '9' "Push 9 onto the stack" $ 175 | pushOp 9 176 | , mkStdOp "A" 'A' "Push 10 onto the stack" $ 177 | pushOp 10 178 | , mkStdOp "B" 'B' "Push 11 onto the stack" $ 179 | pushOp 11 180 | , mkStdOp "C" 'C' "Push 12 onto the stack" $ 181 | pushOp 12 182 | , mkStdOp "D" 'D' "Push 13 onto the stack" $ 183 | pushOp 13 184 | , mkStdOp "E" 'E' "Push 14 onto the stack" $ 185 | pushOp 14 186 | , mkStdOp "F" 'F' "Push 15 onto the stack" $ 187 | pushOp 15 188 | , mkStdOp "GOTO" 'G' "Pop y and x. Move program to (y,x)." $ do 189 | y <- popOp 190 | x <- popOp 191 | arr <- use mem 192 | pc' <- use pc 193 | let tup = (y, x) 194 | if inRange (bounds arr) tup 195 | then do 196 | pc.pos .= tup 197 | pc'' <- use pc 198 | tellDelta $ def { _oldpc = Just pc', _newpc = Just pc'' } 199 | yield 200 | runOp (arr ! (y,x)) 201 | else dieError "Cannot go outside of range" () 202 | , mkStdOp "Fork" 'K' "Fork a thread. Push 1 for child, 0 for parent" $ do 203 | new <- fork 204 | if new 205 | then do 206 | ticks .= 0 207 | pushOp 1 208 | tellMem 209 | else pushOp 0 210 | , mkStdOp "Get" 'g' "Pop y and x. Push memory at (y,x)" $ do 211 | y <- popOp 212 | x <- popOp 213 | arr <- use mem 214 | let tup = (y, x) 215 | if inRange (bounds arr) tup 216 | then pushOp (arr ! tup) 217 | else dieError "g Outside of range." () 218 | , mkStdOp "Put" 'p' "Pop y, x, and v. Write v to (y,x)" $ do 219 | y <- popOp 220 | x <- popOp 221 | v <- popOp 222 | arr <- use mem 223 | let arr' = arr // [(tup, v)] 224 | tup = (y, x) 225 | if inRange (bounds arr) tup 226 | then do 227 | mem .= arr' 228 | tellMem 229 | else dieError "p Outside of range." () 230 | , mkStdOp "Call" 'c' "Pop y and x. Run opcode at (y,x)" $ do 231 | y <- popOp 232 | x <- popOp 233 | arr <- use mem 234 | let tup = (y, x) 235 | if inRange (bounds arr) tup 236 | then runOp (arr ! (y,x)) 237 | else dieError "c Outside of range." () 238 | , mkStdOp "Execute" 'e' "Pop x and run the corresponding opcode." $ do 239 | x <- popOp 240 | runOp x 241 | , mkStdOp "Quantize" 'q' "Wait for the next beat" $ do 242 | let quant = do 243 | bt <- getTime 244 | if (bt^.subbeat) == 0 245 | then return () 246 | else yield >> quant 247 | quant 248 | , mkStdOp "QuantizeN" 'Q' 249 | "Pop x. Wait for a beat that is divisible by x." $ do 250 | x <- fromIntegral <$> popOp 251 | let quant = do 252 | bt <- getTime 253 | if (bt^.subbeat) == 0 && (bt^.beat) `mod` x == 0 254 | then return () 255 | else yield >> quant 256 | if x == 0 257 | then dieError "Can't quantize on 0 beats." () 258 | else quant 259 | , mkStdOp "Sleep" 's' "Pop x. Sleep for x subbeats." $ do 260 | x <- popOp 261 | forM_ [1..x] $ const yield 262 | , mkStdOp "Swap" '\\' "Swap the top two items on the stack" $ do 263 | a <- popOp 264 | b <- popOp 265 | pushOp a 266 | pushOp b 267 | , mkStdOp "Chomp" '$' "Discard the top item on the stack" $ do 268 | void popOp 269 | , mkStdOp "Null?" 'N' "Push 1 if stack is empty or 0." $ do 270 | st <- use stack 271 | case pop st of 272 | Nothing -> pushOp 1 273 | _ -> pushOp 0 274 | , mkStdOp "Jump" '#' "Jump over the next opcode." $ do 275 | jump .= True 276 | , mkStdOp "Quote" '"' "Start/Stop quote mode." $ do 277 | quote .= True 278 | , mkStdOp "Defun" '[' "Start/Stop a function definition." $ do 279 | fnStack .= Just [] 280 | , mkStdOp "Dup" ':' "Duplicate the top object on the stack." $ do 281 | a <- popOp 282 | pushOp a 283 | pushOp a 284 | , mkStdOp "Cond(V)" '|' "Pop x. If x is 0, go down, otherwise go up." $ do 285 | a <- popOp 286 | if a == 0 287 | then pc.dir .= D 288 | else pc.dir .= U 289 | , mkStdOp "Cond(H)" '_' "Pop x. If x is 0, go right, else left." $ do 290 | a <- popOp 291 | if a == 0 292 | then pc.dir .= R 293 | else pc.dir .= L 294 | , mkStdOp "Cond(Jump)" '\'' "Pop x. If x is 0, jump." $ do 295 | a <- popOp 296 | when (a == 0) $ jump .= True 297 | , mkStdOp "Random(Dir)" '?' "Change to a random direction." $ do 298 | r <- rand $ randomR (0, 3) 299 | let d = case (r :: Int) of 300 | 0 -> L 301 | 1 -> R 302 | 2 -> U 303 | 3 -> D 304 | _ -> error "Random failure in ?" 305 | pc.dir .= d 306 | , mkStdOp "Random(Byte)" 'r' "Push a random byte onto the stack." $ do 307 | r <- rand $ random 308 | pushOp r 309 | , mkStdOp "Random(Range)" 'R' 310 | "Pop x and y. Push a random byte between x and y (inclusive)." $ do 311 | a <- popOp 312 | b <- popOp 313 | r <- rand $ randomR (b, a) 314 | pushOp r 315 | , mkStdOp "Not" '!' "Pop x. If x is 0, push 1, else push 0." $ do 316 | a <- popOp 317 | if a == 0 318 | then pushOp 1 319 | else pushOp 0 320 | , mkStdOp "Eq" '=' "Pop x and y. If x = y, push 1, else push 0." $ do 321 | a <- popOp 322 | b <- popOp 323 | if b == a 324 | then pushOp 1 325 | else pushOp 0 326 | , mkStdOp "GT" '`' "Pop x and y. If y > x, push 1, else push 0." $ do 327 | a <- popOp 328 | b <- popOp 329 | if b > a 330 | then pushOp 1 331 | else pushOp 0 332 | , mkStdOp "Add" '+' "Pop x and y. Push y + x." $ do 333 | a <- popOp 334 | b <- popOp 335 | pushOp (a + b) 336 | , mkStdOp "Sub" '-' "Pop x and y. Push y - x." $ do 337 | a <- popOp 338 | b <- popOp 339 | pushOp (b - a) 340 | , mkStdOp "Mul" '*' "Pop x and y. Push y * x." $ do 341 | a <- popOp 342 | b <- popOp 343 | pushOp (a * b) 344 | , mkStdOp "Div" '/' "Pop x and y. Push y / x." $ do 345 | a <- popOp 346 | b <- popOp 347 | if a /= 0 348 | then pushOp (b `div` a) 349 | else do 350 | dieError "Divide by zero" 255 >>= pushOp 351 | , mkStdOp "DivMod" 'd' "Pop x and y. Push y / x and y % x." $ do 352 | a <- popOp 353 | b <- popOp 354 | if a /= 0 355 | then 356 | let (d, m) = b `divMod` a 357 | in pushOp d >> pushOp m 358 | else do 359 | dieError "DivMod by zero" 255 >>= pushOp 360 | , mkStdOp "Mod" '%' "Pop x and y. Push y % x." $ do 361 | a <- popOp 362 | b <- popOp 363 | if a /= 0 364 | then pushOp (b `mod` a) 365 | else do 366 | dieError "Modulo by zero" 0 >>= pushOp 367 | , mkStdOp "Output" '.' "Pop x. Write x to output buffer." $ do 368 | a <- popOp 369 | outbuf <- use progOut 370 | writeBuf outbuf a 371 | , mkStdOp "Broadcast" ';' "Pop x. Broadcast x to output buffer." $ do 372 | a <- popOp 373 | outbuf <- use progOut 374 | bcastBuf outbuf a 375 | , mkStdOp "Read" '~' "Read a value from input buffer and push it." $ do 376 | inbuf <- use progIn 377 | ch <- readBuf inbuf 378 | pushOp ch 379 | , mkStdOp "Print(Char)" ',' "Pop x. Print x as a character." $ do 380 | a <- (chr . fromIntegral) `fmap` popOp 381 | tellDelta $ def { _events = [StringEvent [a]] } 382 | , mkStdOp "Print(Byte)" '&' "Pop x. Print x as a number." $ do 383 | a <- popOp 384 | tellDelta $ def { _events = [StringEvent $ show a] } 385 | , mkStdOp "Major" 'M' "Pop x. Play major chord of pitch x." $ do 386 | nb <- use noteBuf 387 | n <- case nb of 388 | Nothing -> dieError "Can't play empty note" def 389 | (Just n) -> return n 390 | let nes = do 391 | ch <- [0, 4, 7] 392 | return $ NoteEvent (pitch %~ (ch +) $ n) 393 | tellDelta $ def { _events = nes } 394 | , mkStdOp "Minor" 'm' "Pop x. Play minor chord of pitch x." $ do 395 | nb <- use noteBuf 396 | n <- case nb of 397 | Nothing -> dieError "Can't play empty note" def 398 | (Just n) -> return n 399 | let nes = do 400 | ch <- [0, 3, 7] 401 | return $ NoteEvent (pitch %~ (ch +) $ n) 402 | tellDelta $ def { _events = nes } 403 | , mkStdOp "Major7" 'L' "Pop x. Play major 7th chord of pitch x." $ do 404 | nb <- use noteBuf 405 | n <- case nb of 406 | Nothing -> dieError "Can't play empty note" def 407 | (Just n) -> return n 408 | let nes = do 409 | ch <- [0, 4, 7, 11] 410 | return $ NoteEvent (pitch %~ (ch +) $ n) 411 | tellDelta $ def { _events = nes } 412 | , mkStdOp "Minor7" 'l' "Pop x. Play minor 7th chord of pitch x." $ do 413 | nb <- use noteBuf 414 | n <- case nb of 415 | Nothing -> dieError "Can't play empty note" def 416 | (Just n) -> return n 417 | let nes = do 418 | ch <- [0, 3, 7, 11] 419 | return $ NoteEvent (pitch %~ (ch +) $ n) 420 | tellDelta $ def { _events = nes } 421 | , mkStdOp "Write(Note)" 'z' "Pop dur vel pch cha. Write note buffer." $ do 422 | dur <- popOp 423 | vel <- popOp 424 | pit <- popOp 425 | cha <- popOp 426 | noteBuf .= Just (Note cha pit vel dur) 427 | , mkStdOp "Play(Note)" 'Z' "Play the note in the note buffer." $ do 428 | nb <- use noteBuf 429 | ne <- case nb of 430 | Nothing -> dieError "Can't play empty note" (NoteEvent def) 431 | (Just n) -> return $ NoteEvent n 432 | tellDelta $ def { _events = [ne] } 433 | , mkStdOp "Write(Cha)" 'y' 434 | "Pop x. Write x as the note buffer channel." $ do 435 | writeNoteBuf channel 436 | , mkStdOp "Read(Cha)" 'Y' 437 | "Push the channel from the note buffer." $ do 438 | readNoteBuf channel 439 | , mkStdOp "Write(Pch)" 'x' 440 | "Pop x. Write x as the note buffer pitch." $ do 441 | writeNoteBuf pitch 442 | , mkStdOp "Read(Pch)" 'X' 443 | "Push the pitch from the note buffer." $ do 444 | readNoteBuf pitch 445 | , mkStdOp "Write(Vel)" 'w' 446 | "Pop x. Write x as the note buffer veloctiy." $ do 447 | writeNoteBuf velocity 448 | , mkStdOp "Read(Vel)" 'W' 449 | "Push the velocity from the note buffer." $ do 450 | readNoteBuf velocity 451 | , mkStdOp "Write(Dur)" 'u' 452 | "Pop x. Write x as the note buffer duration." $ do 453 | writeNoteBuf duration 454 | , mkStdOp "Read(Dur)" 'U' 455 | "Push the duration from the note buffer." $ do 456 | readNoteBuf duration 457 | , mkStdOp "End" '@' "Terminate the thread." $ do 458 | end 459 | ] 460 | where mkStdOp n c d f = (fromIntegral $ ord c, Operator n c d f) 461 | readNoteBuf l = do 462 | nb <- use noteBuf 463 | nt <- maybe (dieError "Can't read from empty note" def) return nb 464 | pushOp (nt^.l) 465 | writeNoteBuf l = do 466 | val <- popOp 467 | nb <- use noteBuf 468 | nt <- maybe (dieError "Can't read from empty note" def) return nb 469 | noteBuf .= Just (set l val nt) 470 | 471 | operators :: OpSet 472 | operators = OpSet $ Arr.array (0,255) $ do 473 | i <- [0..255] 474 | return (i, (^.opCode) <$> stdOps^.(at i)) 475 | 476 | runOp :: Word8 -> Fungine () 477 | runOp c = do 478 | OpSet ops <- lift $ get 479 | case ops ! c of 480 | Nothing -> dieError ("Unknown operator " ++ show c) () 481 | Just op' -> op' 482 | 483 | -------------------------------------------------------------------------------- /src/Language/NoiseFunge/Befunge/VM.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This source file is a part of the noisefunge programming environment. 3 | 4 | Copyright (C) 2015 Rev. Johnny Healey 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program. If not, see . 18 | -} 19 | 20 | {-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, 21 | UndecidableInstances, FlexibleContexts #-} 22 | 23 | module Language.NoiseFunge.Befunge.VM (VM(..), ProcessStateT, 24 | processQueue, buffers, deadProcesses, 25 | idman, newVM, 26 | Process, procID, 27 | Buffer, addProcess, Program, 28 | readQueue, writeQueue, 29 | PID, kill, 30 | ExecStats(..), 31 | VMStats(..), vmStats, 32 | vmPID, vmExec, vmMisc, 33 | yield, readBuf, writeBuf, end, die, 34 | getPID, bcastBuf, fork, rand, 35 | getTime, 36 | getProcessState, 37 | program, advance) where 38 | 39 | import Control.Applicative 40 | import Control.Lens 41 | import Control.Monad 42 | import Control.Monad.Cont 43 | import Control.Monad.Reader 44 | import Control.Monad.State 45 | import Control.Monad.Trans.Cont (liftLocal) 46 | import Control.Monad.Trans.Maybe 47 | import Control.Monad.Writer 48 | 49 | import qualified Data.Binary as B 50 | import Data.Default 51 | import qualified Data.Map as M 52 | import Data.Word 53 | 54 | import System.Random 55 | 56 | import Language.NoiseFunge.Beat 57 | 58 | data Queue a = Q [a] [a] 59 | 60 | qPush :: a -> Queue a -> Queue a 61 | qPush a (Q xs ys) = Q xs (a:ys) 62 | 63 | qPop :: Queue a -> Maybe (a, Queue a) 64 | qPop (Q [] []) = Nothing 65 | qPop (Q (x:xs) ys) = Just (x, Q xs ys) 66 | qPop (Q [] ys) = qPop (Q ys []) 67 | 68 | queued :: Lens (Queue a) (Queue b) [a] [b] 69 | queued = lens gettr settr where 70 | gettr (Q x y) = x <> y 71 | settr (Q _ _) x = Q x [] 72 | 73 | instance Semigroup (Queue a) where 74 | (<>) = mappend 75 | 76 | instance Monoid (Queue a) where 77 | mempty = Q [] [] 78 | mappend (Q x1 y1) (Q x2 y2) = Q x1 (y2 ++ (reverse x2) ++ y1) 79 | 80 | instance Functor Queue where 81 | fmap f (Q x y) = Q (fmap f x) (fmap f y) 82 | 83 | -- Exec is the running state of a Process at any guven time 84 | data Exec w s m = 85 | Running (ProcessStateT w s m ()) -- yields 86 | | Halted (Maybe String) -- terminates 87 | | WBlock String Bool w (ProcessStateT w s m ()) -- blocking write 88 | | RBlock String (w -> ProcessStateT w s m ()) -- blocking read 89 | | PPID (PID -> ProcessStateT w s m ()) -- get PID from VM 90 | | Fork (Bool -> ProcessStateT w s m ()) -- fork a new microthread 91 | | Rand (StdGen -> (ProcessStateT w s m (), StdGen)) -- random 92 | | Time (Beat -> ProcessStateT w s m ()) -- get the current beat 93 | 94 | -- A ProcessM is a continuation monad that returns an Exec over the state of 95 | -- a process. 96 | type ProcessM w s m = ContT (Exec w s m) (StateT s m) 97 | 98 | -- A Trap function takes an Exec and returns a ProcessM. This is ultimately 99 | -- used with callCC in a ProcessStateT to allow the process to yield, block, 100 | -- or receive data from the VM. 101 | type Trap w s m = Exec w s m -> ProcessM w s m () 102 | 103 | -- A ProcessStateT is a ProcessM with a reader over it for its Trap. 104 | newtype ProcessStateT w s m a = PST { 105 | runPST :: ReaderT (Trap w s m) (ProcessM w s m) a } 106 | 107 | -- succeed lifts a ProcessM into a ProcessStateT 108 | succeed :: ProcessM w s m a -> ProcessStateT w s m a 109 | succeed m = PST $ lift m 110 | 111 | -- run a ProcessStateT for the given state. Return an Exec and the updated 112 | -- state. 113 | runPS :: Monad m => ProcessStateT w s m a -> s -> m (Exec w s m, s) 114 | runPS (PST pst) s = runStateT (runContT runner return) s where 115 | runner = callCC $ \trap -> do 116 | void $ runReaderT pst trap 117 | return (Halted Nothing) 118 | 119 | instance Functor m => Functor (ProcessStateT w s m) where 120 | fmap f (PST m) = PST $ fmap f m 121 | 122 | instance Applicative m => Applicative (ProcessStateT w s m) where 123 | pure = succeed . pure 124 | (PST f) <*> (PST a) = PST (f <*> a) 125 | 126 | instance MonadTrans (ProcessStateT w s) where 127 | lift = succeed . lift . lift 128 | 129 | instance MonadIO m => MonadIO (ProcessStateT w s m) where 130 | liftIO = succeed . liftIO 131 | 132 | instance Monad m => Monad (ProcessStateT w s m) where 133 | return = succeed . return 134 | m >>= f = PST $ do 135 | a <- runPST m 136 | runPST (f a) 137 | 138 | instance (Monoid w', MonadWriter w' m) => 139 | MonadWriter w' (ProcessStateT w s m) where 140 | tell = succeed . lift . lift . tell 141 | listen m = m >>= succeed . lift . lift . listen . return 142 | pass m = m >>= succeed . lift . lift . pass . return 143 | 144 | instance MonadReader r m => MonadReader r (ProcessStateT w s m) where 145 | ask = succeed . lift . lift $ ask 146 | local f (PST m) = PST $ mapReaderT (liftLocal ask (mapStateT . local) f) m 147 | 148 | instance Monad m => MonadState s (ProcessStateT w s m) where 149 | get = succeed . lift $ get 150 | put = succeed . lift . put 151 | 152 | type PID = (Word32, String) 153 | 154 | -- A Process is a running microthread in noisefunge. It has a PID, an ExecState 155 | -- and its own state. 156 | data Process w s m = Process { 157 | _procID :: !PID, 158 | _procExec :: Exec w s m, 159 | _procState :: s 160 | } 161 | 162 | -- Buffers are used for IPC via input/output channels. 163 | data Buffer w s m = Buffer { 164 | _readQueue :: Queue (Process w s m), 165 | _writeQueue :: Queue (Process w s m), 166 | _bcastValues :: [w] 167 | } 168 | 169 | instance Semigroup (Buffer w s m) where 170 | (<>) = mappend 171 | 172 | instance Monoid (Buffer w s m) where 173 | mempty = Buffer mempty mempty mempty 174 | mappend (Buffer r1 w1 b1) (Buffer r2 w2 b2) = 175 | Buffer (r1 <> r2) (w1 <> w2) (b1 <> b2) 176 | 177 | instance Default (Buffer w s m) where 178 | def = mempty 179 | 180 | -- IDManager is used to prevent duplication of the PID numbers 181 | data IDManager = IDMan !Word32 [Word32] 182 | deriving (Show, Eq, Ord) 183 | 184 | newID :: IDManager -> (Word32, IDManager) 185 | newID (IDMan w (x:xs)) = (x, IDMan w xs) 186 | newID (IDMan w []) = (w, IDMan (w+1) []) 187 | 188 | freeID :: Word32 -> IDManager -> IDManager 189 | freeID x (IDMan w xs) = IDMan w (x:xs) 190 | 191 | instance Default IDManager where 192 | def = IDMan 0 [] 193 | 194 | -- VM is kind of a misleading name. This isn't a virtual machine as much as the 195 | -- main data structure that contains the state of all of the processes and 196 | -- output buffers at any given point in time. 197 | data VM w s m = VM { 198 | _processQueue :: Queue (Process w s m), 199 | _buffers :: M.Map String (Buffer w s m), 200 | _deadProcesses :: [(PID, Maybe String, Process w s m)], 201 | _idman :: IDManager, 202 | _gen :: StdGen 203 | } 204 | 205 | instance Default (VM w s m) where 206 | def = VM mempty mempty mempty def (mkStdGen 1) 207 | 208 | newVM :: IO (VM w s m) 209 | newVM = VM mempty mempty mempty def <$> newStdGen 210 | 211 | $(makeLenses ''VM) 212 | $(makeLenses ''Process) 213 | $(makeLenses ''Buffer) 214 | 215 | -- To kill a process, set the state to Halted with an optional reason. 216 | kill :: Maybe String -> Process w s m -> Process w s m 217 | kill reas proc = set procExec (Halted reas) proc 218 | 219 | -- trap is an operation in the ProcessStateT monad that takes a function which 220 | -- converts the current continuation into an Exec. It then uses callCC to 221 | trap :: ((a -> ProcessStateT w s m b) -> Exec w s m) -> ProcessStateT w s m a 222 | trap f = PST $ do 223 | e <- ask 224 | lift $ callCC $ \k -> do 225 | let ex = f (succeed . k) 226 | e ex 227 | undefined -- We will never reach this line 228 | 229 | yield :: ProcessStateT w s m () 230 | yield = trap $ \k -> Running (k ()) 231 | 232 | fork :: ProcessStateT w s m Bool 233 | fork = trap Fork 234 | 235 | readBuf :: String -> ProcessStateT w s m w 236 | readBuf buf = trap $ RBlock buf 237 | 238 | writeBuf :: String -> w -> ProcessStateT w s m () 239 | writeBuf buf w = trap $ \k -> WBlock buf False w (k ()) 240 | 241 | bcastBuf :: String -> w -> ProcessStateT w s m () 242 | bcastBuf buf w = trap $ \k -> WBlock buf True w (k ()) 243 | 244 | rand :: Random a => (StdGen -> (a, StdGen)) -> ProcessStateT w s m a 245 | rand fn = trap $ \k -> Rand $ \g -> 246 | let (a, g') = fn g 247 | in (k a, g') 248 | 249 | end :: ProcessStateT w s m a 250 | end = trap (const (Halted Nothing)) 251 | 252 | die :: String -> ProcessStateT w s m a 253 | die s = trap (const (Halted (Just s))) 254 | 255 | getPID :: ProcessStateT w s m PID 256 | getPID = trap PPID 257 | 258 | getTime :: ProcessStateT w s m Beat 259 | getTime = trap Time 260 | 261 | getProcessState :: Monad m => ProcessStateT w s m s 262 | getProcessState = succeed . lift $ get 263 | 264 | type Program w s m = PID -> Process w s m 265 | 266 | program :: Monad m => s -> ProcessStateT w s m a -> Program w s m 267 | program s pst pid = Process pid (Running $ pst >> end) s 268 | 269 | makeProcess :: String -> Program w s m -> VM w s m -> (Process w s m, VM w s m) 270 | makeProcess name f vm = (f pid, set idman ids vm) where 271 | pid = (w, name) 272 | (w, ids) = newID (vm^.idman) 273 | 274 | queueProcess :: Process w s m -> VM w s m -> VM w s m 275 | queueProcess p = processQueue %~ qPush p 276 | 277 | addProcess :: String -> Program w s m -> VM w s m -> (Process w s m, VM w s m) 278 | addProcess name f vm = (p, queueProcess p vm') where 279 | (p, vm') = makeProcess name f vm 280 | 281 | 282 | -- These lenses are meant to be used in the StateT monad in the advance 283 | -- function. They are meant to give semantic meaning to commonly used 284 | -- lenses. 285 | 286 | currentVM :: Simple Lens (VM w s m, Queue (Process w s m)) (VM w s m) 287 | currentVM = _1 288 | 289 | currentQueue :: Simple Lens (VM w s m, Queue (Process w s m)) 290 | (Queue (Process w s m)) 291 | currentQueue = _1.processQueue 292 | 293 | doneQueue :: Simple Lens (VM w s m, Queue (Process w s m)) 294 | (Queue (Process w s m)) 295 | doneQueue = _2 296 | 297 | 298 | -- advance the VM. This takes the current Beat and VM and returns the VM state 299 | -- after a single tick of the clock. A tick runs all non-blocked tasklets until 300 | -- they yield or are blocked. 301 | -- 302 | -- The state in the StateT monad is a tuple of the VM and queue of processes 303 | -- that have finished their tick. 304 | advance :: (Monad m, Functor m) => Beat -> VM w s m -> m (VM w s m) 305 | advance bt vm = flip evalStateT (vm, mempty) $ initialize >> advanced where 306 | initialize = zoom currentVM $ do 307 | -- Clean up the killed processes 308 | killed <- execWriterT $ do 309 | zoom processQueue filterQueue 310 | zoom (buffers.traverse) $ do 311 | zoom readQueue filterQueue 312 | zoom writeQueue filterQueue 313 | deadProcesses .= killed [] 314 | filterQueue = do 315 | qd <- use queued 316 | qd' <- filterM filterDead qd 317 | queued .= qd' 318 | filterDead p = case (p^.procExec) of 319 | (Halted r) -> do 320 | tell ((p^.procID, r, p):) 321 | return False 322 | _ -> return True 323 | advanced = do 324 | -- run a queued process if one exits. Otherwise run a buffered 325 | -- process. 326 | res <- runMaybeT $ runQueued bt <|> runBuffers 327 | case res of 328 | Nothing -> do -- Nothing (left to) do 329 | currentVM.buffers %= fmap (set bcastValues []) 330 | updateIDM 331 | 332 | -- replace the processQueue with the finished processes 333 | pq <- use doneQueue 334 | currentQueue .= pq 335 | use currentVM 336 | _ -> advanced -- still work to do 337 | -- free the IDs of the dead processes 338 | updateIDM = do 339 | dead <- use (currentVM.deadProcesses) 340 | forM_ dead $ \((pid,_),_, _) -> do 341 | currentVM.idman %= freeID pid 342 | 343 | runStep :: Monad m => Process w s m -> m (Exec w s m, s) 344 | runStep p = case (p^.procExec, p^.procState) of 345 | (Running f, s) -> runPS f s 346 | ex -> return ex 347 | 348 | -- run a Queued process, if there are any left on the queue. 349 | runQueued :: Monad m => Beat -> 350 | MaybeT (StateT (VM w s m, Queue (Process w s m)) m) () 351 | runQueued bt = do 352 | q <- use (currentQueue) 353 | (p, q') <- MaybeT (return $ qPop q) 354 | currentQueue .= q' 355 | (ex, s) <- lift . lift $ runStep p 356 | let p' = set procExec ex $ set procState s $ p 357 | pid = p^.procID 358 | case ex of 359 | -- process yielded 360 | Running _ -> do 361 | -- onto the finished (for this tick) queue 362 | doneQueue %= qPush p' 363 | 364 | --process halted 365 | Halted reas -> do 366 | currentVM.deadProcesses %= ((pid, reas, p'):) 367 | 368 | -- process ends up blocked on a write buffer 369 | WBlock bname False _ _ -> do -- 370 | buf <- use (currentVM.buffers.(at bname)) 371 | let buf' = maybe mempty id buf 372 | buf'' = buf' & writeQueue %~ qPush p' 373 | currentVM.buffers.(at bname) .= Just buf'' 374 | return $ () 375 | 376 | -- process broadcasts a value to a write buffer and continues 377 | WBlock bname True w f -> do 378 | buf <- use (currentVM.buffers.(at bname)) 379 | let buf' = maybe mempty id buf 380 | buf'' = buf' & bcastValues %~ (w:) 381 | currentVM.buffers.(at bname) .= Just buf'' 382 | -- back onto the active queue for this tick 383 | currentQueue %= qPush (set procExec (Running f) p') 384 | 385 | -- block on the read queue 386 | RBlock bname _ -> do 387 | buf <- use (currentVM.buffers.(at bname)) 388 | let buf' = maybe mempty id buf 389 | buf'' = buf' & readQueue %~ qPush p' 390 | currentVM.buffers.(at bname) .= Just buf'' 391 | 392 | -- run the random function. Updating the StdGen of the VM. 393 | Rand f -> do 394 | f' <- currentVM.gen %%= f 395 | -- back onto the active queue for this tick 396 | currentQueue %= qPush (set procExec (Running f') p') 397 | 398 | -- process requests its PID 399 | PPID f -> do 400 | -- back onto the active queue for this tick 401 | currentQueue %= qPush (set procExec (Running (f pid)) p') 402 | 403 | -- process wants to fork 404 | Fork f -> do 405 | currentQueue %= qPush (set procExec (Running (f False)) p') 406 | let prog = program (p^.procState) (f True) 407 | -- make a new process based on the Exec of the current proces. 408 | -- (automatically queued) 409 | c <- currentVM %%= makeProcess (p^.procID._2) prog 410 | -- back onto the active queue for this tick 411 | currentQueue %= qPush c 412 | 413 | -- process wants the current beat. 414 | Time f -> do 415 | -- back onto the active queue for this tick 416 | currentQueue %= qPush (set procExec (Running (f bt)) p') 417 | 418 | -- Iterate through the buffers and run the next process that can read or 419 | -- write from a buffer. 420 | runBuffers :: (Monad m) => 421 | MaybeT (StateT (VM w s m, Queue (Process w s m)) m) () 422 | runBuffers = do 423 | bufs <- use (currentVM.buffers) 424 | let (bufs', ps) = runWriter . forM (M.toList bufs) $ \(bn, buf) -> do 425 | let (buf', p) = handleBuffer buf 426 | tell (p++) 427 | return (bn, buf') 428 | case (ps []) of 429 | [] -> fail "" -- no processes freed by the buffers 430 | ps' -> do 431 | -- update the buffers 432 | currentVM.buffers .= M.fromList bufs' 433 | -- add the unblocked processes to the current running queue 434 | mapM_ ((currentQueue %=) . qPush) ps' 435 | return () 436 | 437 | -- Run through a buffer and return a list of any Processes that are no longer 438 | -- blocked on the buffer. 439 | handleBuffer :: Buffer w s m -> (Buffer w s m, [Process w s m]) 440 | handleBuffer buf = (buf'', concatMap (uncurry comm) ps) where 441 | (ps, buf') = pairs (cycleBC buf) 442 | buf'' = set bcastValues (buf^.bcastValues) buf' 443 | comm rp (Right wp) = 444 | let (WBlock _ _ w wres) = wp^.procExec 445 | (RBlock _ rres) = rp^.procExec 446 | in [set procExec (Running (rres w)) rp, 447 | set procExec (Running wres) wp] 448 | comm rp (Left w) = 449 | let (RBlock _ rres) = rp^.procExec 450 | in [set procExec (Running (rres w)) rp] 451 | -- multiple broadcasts cycle among eachother. 452 | cycleBC b@(Buffer _ _ []) = b 453 | cycleBC (Buffer rq wq l) = Buffer rq wq (cycle l) 454 | pair b = pairQ b <|> pairBC b 455 | pairQ b = do 456 | (r, rq) <- qPop (b^.readQueue) 457 | (w, wq) <- qPop (b^.writeQueue) 458 | return (r, Right w, Buffer rq wq (b^.bcastValues)) 459 | pairBC b = do 460 | (r, rq) <- qPop (b^.readQueue) 461 | (w, ws) <- uncons (b^.bcastValues) 462 | return (r, Left w, Buffer rq (b^.writeQueue) ws) 463 | pairs b = case pair b of 464 | Nothing -> ([], set bcastValues [] b) 465 | Just (r, w, b') -> 466 | let (ps', b'') = pairs b' 467 | in ((r,w):ps', b'') 468 | 469 | data ExecStats = 470 | ERunning 471 | | EHalted (Maybe String) 472 | | ERBlock String 473 | | EWBlock String 474 | deriving (Read, Show, Eq, Ord) 475 | 476 | exStats :: Exec w s m -> ExecStats 477 | exStats (Halted r) = EHalted r 478 | exStats (WBlock b _ _ _) = EWBlock b 479 | exStats (RBlock b _) = ERBlock b 480 | exStats _ = ERunning 481 | 482 | instance B.Binary ExecStats where 483 | get = B.getWord8 >>= getEx where 484 | getEx 0 = return ERunning 485 | getEx 1 = EHalted <$> B.get 486 | getEx 2 = ERBlock <$> B.get 487 | getEx 3 = EWBlock <$> B.get 488 | getEx _ = error "Bad ExecStats" 489 | put ERunning = B.putWord8 0 490 | put (EHalted a) = B.putWord8 1 >> B.put a 491 | put (ERBlock a) = B.putWord8 2 >> B.put a 492 | put (EWBlock a) = B.putWord8 3 >> B.put a 493 | 494 | data VMStats s = VMStats { 495 | _vmPID :: PID, 496 | _vmExec :: ExecStats, 497 | _vmMisc :: s 498 | } deriving (Read, Show, Eq, Ord) 499 | 500 | $(makeLenses ''VMStats) 501 | 502 | instance Functor VMStats where 503 | fmap f (VMStats pid ex a) = VMStats pid ex (f a) 504 | 505 | vmStats :: Getter (VM w s m) [VMStats s] 506 | vmStats = to vmStats' where 507 | vmStats' vm = 508 | let running = do 509 | p <- vm^.processQueue.queued 510 | return $ VMStats (p^.procID) (p^.procExec.(to exStats)) 511 | (p^.procState) 512 | blocked = do 513 | buf <- vm^.buffers.(to M.elems) 514 | p <- (buf^.readQueue.queued) <> (buf^.writeQueue.queued) 515 | return $ VMStats (p^.procID) (p^.procExec.(to exStats)) 516 | (p^.procState) 517 | halted = do 518 | (_,_,p) <- vm^.deadProcesses 519 | return $ VMStats (p^.procID) (p^.procExec.(to exStats)) 520 | (p^.procState) 521 | in running <> blocked <> halted 522 | 523 | instance B.Binary a => B.Binary (VMStats a) where 524 | get = VMStats <$> B.get <*> B.get <*> B.get 525 | put (VMStats a b c) = B.put a >> B.put b >> B.put c 526 | 527 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | --------------------------------------------------------------------------------