Compare commits
10 commits
f2b0e8fee0
...
12e100c417
| Author | SHA1 | Date | |
|---|---|---|---|
|
12e100c417 | ||
|
|
e564146c4c | ||
|
|
16925c182e | ||
|
|
1d0d27cf07 | ||
|
|
68c7916fa4 | ||
|
|
95808f5a9b | ||
|
|
bdda683c42 | ||
|
|
d582c20af3 | ||
|
|
b45de145fe | ||
|
|
8ba2ad5da5 |
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -1,4 +1,4 @@
|
||||||
result
|
result
|
||||||
result-doc
|
result-doc
|
||||||
*.swp
|
*.swp
|
||||||
|
*.prof
|
||||||
|
|
|
||||||
11
LICENSE
11
LICENSE
|
|
@ -1,2 +1,9 @@
|
||||||
if u use dis repo u agree to not be a chud.
|
Copyright 2021 Thorn Avery
|
||||||
military and corps get out.
|
|
||||||
|
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
|
||||||
125
README.md
125
README.md
|
|
@ -1,11 +1,11 @@
|
||||||
# cellularAutomata
|
# cellularAutomata
|
||||||
|
|
||||||
a small application for running a one-dimensional cellular automata from random inputs, using comonads
|
a small application for running cellular automata from random inputs, using comonads
|
||||||
|
|
||||||
## usage
|
## usage
|
||||||
|
|
||||||
the program will default to the size of the window
|
the program will default to the size of the window
|
||||||
`-w` and `-g` inputs can be given to determine the width and height, respectively
|
`-w` and `-h` inputs can be given to determine the width and height, respectively
|
||||||
|
|
||||||
## requirements
|
## requirements
|
||||||
|
|
||||||
|
|
@ -69,123 +69,8 @@ due to haskell's laziness, the comonad space can (and should) be infinite in bot
|
||||||
|
|
||||||
as such, the functions to change our focus within the space assumes an infinite list, and i have defaulted to "clamping" our focus at the edges if a finite list is given on either direction. im not sure this is semantically the correct choice, but in regular usage (with infinite lists) it should not come up.
|
as such, the functions to change our focus within the space assumes an infinite list, and i have defaulted to "clamping" our focus at the edges if a finite list is given on either direction. im not sure this is semantically the correct choice, but in regular usage (with infinite lists) it should not come up.
|
||||||
|
|
||||||
## example
|
currently, as we are animating in a window, the program will turn the initially infinite grid into a grid the size of the window, therefore avoidinig memory leaks at the sides.
|
||||||
|
|
||||||
`./cellularAutomata -w 40 -g 25`
|
in the future if we add the ability to render animated gifs of a cellular automata, it may be of use to keep the infinite grid, in the knowledge that we will not be running it indefinitely, but instead collecting garbage at the end of the animation.
|
||||||
|
|
||||||
```
|
this is the difference between a truly infinite grid, and one that is simply larger than our viewspace (but still finite).
|
||||||
██ ████ █ █████ █ ███ █ ███ ███
|
|
||||||
██ █ ███ █ ██ █ ███ ██ █ █ █ █ ██
|
|
||||||
█ ███ ███ █ ███ █ █ ██ ██ ███
|
|
||||||
███ █ █ █ █ ██ █ ███████ ██ ██
|
|
||||||
███ █ █ █ ██ █ ██ ██ ███ ██
|
|
||||||
█ █ █ ██████ █████ ██████ █ █
|
|
||||||
██ ██ █ █ █ ██ █ █ ██ ██ █
|
|
||||||
██ ██ ██ ███ █ █ ███ ███ █ █ █
|
|
||||||
█ ███████ ██ ███ █ █ █ █ █ ███ █ ██
|
|
||||||
█ █ █████ █ █ ██ █ ██ █ █
|
|
||||||
███ █ ██ █ █ ████ █ ██ ██
|
|
||||||
█ █ █ ████ █ █ █ ███ ██ █ █████████
|
|
||||||
██ █ █ ██ █ ███████ █ ██
|
|
||||||
█████ ██ █ █████ █ ███ █ ███
|
|
||||||
██ █ ██ ███ ███ █ ██ █ █ ██
|
|
||||||
████ █ █████ ██ ██ █ █ ███ ██ █ ████
|
|
||||||
█ ███ █ ██ ██ ██ █ █████ █ ██
|
|
||||||
█ █ ███ ██ █ ██ ████████ █ ██ █ ███
|
|
||||||
█ █ █ ██ ████ █ ███ █ ███ █ █
|
|
||||||
██ █ █████ █ █ ██ █ █ ██ █
|
|
||||||
██ █ ██ ███ ██ █ ███ █ █ ██ █ █
|
|
||||||
████ █████ ██ █ ██ ███ ███ ██████ ███
|
|
||||||
█ █ █ ██ █████ █ █ ██ ██ █ █
|
|
||||||
█ █ █ ███ ██ █ ██ ███ █ █
|
|
||||||
██ █ █ ███ █ ███ █ █ ███ █ ███ █ █
|
|
||||||
█ █ ██ █ █ █ █ ██ █ █ █ ██
|
|
||||||
```
|
|
||||||
|
|
||||||
example using `rule3` and a non-random starting position:
|
|
||||||
|
|
||||||
`./cellularAutomata -w 80 -g 80`
|
|
||||||
|
|
||||||
```
|
|
||||||
█
|
|
||||||
███
|
|
||||||
█ █ █
|
|
||||||
██ █ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █
|
|
||||||
██ ██ ███ ██ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ██ ██ ██ █ ██ ██ ██ ██ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ███ ██ ██ ██ ██ ███ ██ ██ ██ ██ ███ ██ ██
|
|
||||||
█ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ███ ██ ██ ██ ██ ███ ██ ██ ██ ██ ███ ██ ██
|
|
||||||
█ █ █ █ █ █ █ █
|
|
||||||
█ ███ ███ ███ ███ ███ ███ ███ ██
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
█ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ██
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ █ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ █ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ █ ██ ██ █
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ███ ██ ██ ██ ██ ███ ██ ██ ██ ██ ███ ██ ██
|
|
||||||
█ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ █ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██ ██
|
|
||||||
█
|
|
||||||
███
|
|
||||||
█ █ █
|
|
||||||
██ █ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █
|
|
||||||
██ ██ ███ ██ ██
|
|
||||||
█ █ █
|
|
||||||
███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █
|
|
||||||
██ █ ██ ██ █ ██ ██ █ ██
|
|
||||||
█ █ █ █ █
|
|
||||||
███ ███ ███ ███ ███
|
|
||||||
█ █ █ █ █ █ █ █ █ █ █
|
|
||||||
██ ██ ██ ██ ██ █ ██ ██ ██ ██ ██
|
|
||||||
█ █ █
|
|
||||||
```
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@ cabal-version: >=1.10
|
||||||
-- init'. For further documentation, see
|
-- init'. For further documentation, see
|
||||||
-- http://haskell.org/cabal/users-guide/
|
-- http://haskell.org/cabal/users-guide/
|
||||||
|
|
||||||
name: cellularAutomata
|
name: cellular-automata
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
-- synopsis:
|
-- synopsis:
|
||||||
-- description:
|
-- description:
|
||||||
|
|
@ -11,20 +11,28 @@ version: 0.1.0.0
|
||||||
-- license:
|
-- license:
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Thorn Avery
|
author: Thorn Avery
|
||||||
maintainer: s@p7.co.nz
|
maintainer: ta@p7.co.nz
|
||||||
-- copyright:
|
-- copyright:
|
||||||
-- category:
|
-- category:
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
|
|
||||||
executable cellularAutomata
|
executable cellularAutomata
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
ghc-options: -threaded
|
||||||
|
-O2
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base >=4.13 && <4.14
|
build-depends: base
|
||||||
, random
|
, random
|
||||||
, turtle
|
, turtle
|
||||||
, brick
|
, brick
|
||||||
, process
|
, process
|
||||||
|
, containers
|
||||||
|
, linear
|
||||||
|
, microlens
|
||||||
|
, microlens-th
|
||||||
|
, vty
|
||||||
|
, deepseq
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
extra-libraries: ncurses
|
extra-libraries: ncurses
|
||||||
43
flake.lock
43
flake.lock
|
|
@ -1,43 +0,0 @@
|
||||||
{
|
|
||||||
"nodes": {
|
|
||||||
"flake-utils": {
|
|
||||||
"locked": {
|
|
||||||
"lastModified": 1601282935,
|
|
||||||
"narHash": "sha256-WQAFV6sGGQxrRs3a+/Yj9xUYvhTpukQJIcMbIi7LCJ4=",
|
|
||||||
"owner": "numtide",
|
|
||||||
"repo": "flake-utils",
|
|
||||||
"rev": "588973065fce51f4763287f0fda87a174d78bf48",
|
|
||||||
"type": "github"
|
|
||||||
},
|
|
||||||
"original": {
|
|
||||||
"owner": "numtide",
|
|
||||||
"repo": "flake-utils",
|
|
||||||
"type": "github"
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"nixpkgs": {
|
|
||||||
"locked": {
|
|
||||||
"lastModified": 1604368813,
|
|
||||||
"narHash": "sha256-UOLaURSO448k+4bGJlaSMYeo2F5F6CuFo9VoYDkhmsk=",
|
|
||||||
"owner": "NixOS",
|
|
||||||
"repo": "nixpkgs",
|
|
||||||
"rev": "d105075a1fd870b1d1617a6008cb38b443e65433",
|
|
||||||
"type": "github"
|
|
||||||
},
|
|
||||||
"original": {
|
|
||||||
"owner": "NixOS",
|
|
||||||
"ref": "nixos-20.09",
|
|
||||||
"repo": "nixpkgs",
|
|
||||||
"type": "github"
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"root": {
|
|
||||||
"inputs": {
|
|
||||||
"flake-utils": "flake-utils",
|
|
||||||
"nixpkgs": "nixpkgs"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"root": "root",
|
|
||||||
"version": 7
|
|
||||||
}
|
|
||||||
19
flake.nix
19
flake.nix
|
|
@ -1,19 +0,0 @@
|
||||||
{
|
|
||||||
description = "a basic cellular automata using comonads";
|
|
||||||
inputs = {
|
|
||||||
nixpkgs.url = "github:NixOS/nixpkgs/nixos-20.09";
|
|
||||||
flake-utils.url = "github:numtide/flake-utils";
|
|
||||||
};
|
|
||||||
outputs = { self, nixpkgs, flake-utils, ... }:
|
|
||||||
flake-utils.lib.eachDefaultSystem (system:
|
|
||||||
let
|
|
||||||
pkgs = import nixpkgs {
|
|
||||||
overlays = [ (import ./overlay.nix) ];
|
|
||||||
inherit system;
|
|
||||||
};
|
|
||||||
in {
|
|
||||||
defaultPackage = pkgs.cellularAutomata;
|
|
||||||
}) // {
|
|
||||||
overlay = import ./overlay.nix;
|
|
||||||
};
|
|
||||||
}
|
|
||||||
|
|
@ -1,13 +0,0 @@
|
||||||
{ mkDerivation, base, brick, lib, ncurses, process, random, turtle
|
|
||||||
}:
|
|
||||||
mkDerivation {
|
|
||||||
pname = "cellularAutomata";
|
|
||||||
version = "0.1.0.0";
|
|
||||||
src = ./..;
|
|
||||||
isLibrary = false;
|
|
||||||
isExecutable = true;
|
|
||||||
executableHaskellDepends = [ base brick process random turtle ];
|
|
||||||
executableSystemDepends = [ ncurses ];
|
|
||||||
license = "unknown";
|
|
||||||
hydraPlatforms = lib.platforms.none;
|
|
||||||
}
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
final: prev: {
|
|
||||||
cellularAutomata = (import ./release.nix) prev;
|
|
||||||
}
|
|
||||||
47
release.nix
47
release.nix
|
|
@ -1,47 +0,0 @@
|
||||||
bspkgs:
|
|
||||||
let
|
|
||||||
dontCheckPackages = [ ];
|
|
||||||
doJailbreakPackages = [ ];
|
|
||||||
dontHaddockPackages = [ ];
|
|
||||||
config = {
|
|
||||||
packageOverrides = pkgs: rec {
|
|
||||||
haskellPackages =
|
|
||||||
let
|
|
||||||
generatedOverrides = haskellPackagesNew: haskellPackagesOld:
|
|
||||||
let
|
|
||||||
toPackage = file: _: {
|
|
||||||
name = builtins.replaceStrings [ ".nix" ] [ "" ] file;
|
|
||||||
value = haskellPackagesNew.callPackage
|
|
||||||
( ./. + "/nix/${file}") { };
|
|
||||||
};
|
|
||||||
in
|
|
||||||
pkgs.lib.mapAttrs' toPackage
|
|
||||||
(builtins.readDir ./nix);
|
|
||||||
makeOverrides =
|
|
||||||
function: names: haskellPackagesNew: haskellPackagesOld:
|
|
||||||
let
|
|
||||||
toPackage = name: {
|
|
||||||
inherit name;
|
|
||||||
value = function haskellPackagesOld.${name};
|
|
||||||
};
|
|
||||||
in
|
|
||||||
builtins.listToAttrs (map toPackage names);
|
|
||||||
composeExtensionsList =
|
|
||||||
pkgs.lib.fold pkgs.lib.composeExtensions (_: _: {});
|
|
||||||
manualOverrides = haskellPackagesNew: haskellPackagesOld: {
|
|
||||||
};
|
|
||||||
in
|
|
||||||
pkgs.haskellPackages.override {
|
|
||||||
overrides = composeExtensionsList [
|
|
||||||
generatedOverrides
|
|
||||||
(makeOverrides pkgs.haskell.lib.dontCheck dontCheckPackages)
|
|
||||||
(makeOverrides pkgs.haskell.lib.doJailbreak doJailbreakPackages)
|
|
||||||
(makeOverrides pkgs.haskell.lib.dontHaddock dontHaddockPackages)
|
|
||||||
manualOverrides
|
|
||||||
];
|
|
||||||
};
|
|
||||||
};
|
|
||||||
};
|
|
||||||
pkgs = import bspkgs.path { inherit config; system = bspkgs.system; };
|
|
||||||
in
|
|
||||||
pkgs.haskellPackages.cellularAutomata
|
|
||||||
136
src/Automata.hs
Normal file
136
src/Automata.hs
Normal file
|
|
@ -0,0 +1,136 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
|
module Automata where
|
||||||
|
|
||||||
|
import Comonad
|
||||||
|
import Spaces.Space1
|
||||||
|
import Spaces.Space2
|
||||||
|
import System.Random
|
||||||
|
import GHC.Generics
|
||||||
|
import Control.DeepSeq
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
|
-----------------------
|
||||||
|
-- cellular automata --
|
||||||
|
-----------------------
|
||||||
|
|
||||||
|
-- the states our cells can be in
|
||||||
|
-- may need to provide an ordering
|
||||||
|
-- may need to generalise the number
|
||||||
|
-- of states
|
||||||
|
data CellState = Rock | Paper | Scissors
|
||||||
|
deriving (Eq, Bounded, Enum, Generic)
|
||||||
|
|
||||||
|
instance NFData CellState
|
||||||
|
|
||||||
|
instance Random CellState where
|
||||||
|
random g = case randomR (fromEnum (minBound :: CellState), fromEnum (maxBound :: CellState)) g of
|
||||||
|
(r, g') -> (toEnum r, g')
|
||||||
|
randomR (a,b) g = case randomR (fromEnum a, fromEnum b) g of
|
||||||
|
(r, g') -> (toEnum r, g')
|
||||||
|
|
||||||
|
-- how the states are displayed on screen
|
||||||
|
-- this should probably be input to a function
|
||||||
|
-- rather than hardcoded
|
||||||
|
instance Show CellState
|
||||||
|
where
|
||||||
|
show Rock = "⬤"
|
||||||
|
show Paper = " "
|
||||||
|
show Scissors = "_"
|
||||||
|
|
||||||
|
-- -- a rule stating how a cell is determined
|
||||||
|
-- rule :: Space CellState -> CellState
|
||||||
|
-- rule (Space (l:_) _ (r:_))
|
||||||
|
-- | l == r = Dead
|
||||||
|
-- | otherwise = Alive
|
||||||
|
--
|
||||||
|
-- -- a second rule for example
|
||||||
|
-- rule2 :: Space CellState -> CellState
|
||||||
|
-- rule2 (Space (l1:l2:_) m (r1:r2:_))
|
||||||
|
-- | m == Alive && numAlive == 1 = Dead
|
||||||
|
-- | m == Alive && numAlive == 4 = Dead
|
||||||
|
-- | m == Dead && numAlive == 3 = Alive
|
||||||
|
-- | otherwise = m
|
||||||
|
-- where
|
||||||
|
-- ns = [l1, l2, r1, r2]
|
||||||
|
-- numAlive = length $ filter (== Alive) ns
|
||||||
|
--
|
||||||
|
-- rule3 :: Space CellState -> CellState
|
||||||
|
-- rule3 (Space (l:_) m (r:_))
|
||||||
|
-- | l == r = m
|
||||||
|
-- | otherwise = if m == Alive then Dead else Alive
|
||||||
|
|
||||||
|
------------------------
|
||||||
|
-- grabbing neighbors --
|
||||||
|
------------------------
|
||||||
|
|
||||||
|
-- we want to be able to create a list of (Maybe CellState)
|
||||||
|
-- representing each neighbor, this way it will work on the
|
||||||
|
-- edges, and also we can fix the position of ecah neighbor
|
||||||
|
-- so that rules can be directional also.
|
||||||
|
|
||||||
|
grabNeighbors :: Space2 CellState -> [(Maybe CellState)]
|
||||||
|
grabNeighbors s = let
|
||||||
|
tl = grabTopLeft s
|
||||||
|
t = grabTop s
|
||||||
|
tr = grabTopRight s
|
||||||
|
l = grabLeft s
|
||||||
|
r = grabRight s
|
||||||
|
bl = grabBotLeft s
|
||||||
|
b = grabBot s
|
||||||
|
br = grabBotRight s
|
||||||
|
in [tl, t, tr, l, r, bl, b, br]
|
||||||
|
|
||||||
|
grabTemplate :: (Space2 CellState -> Maybe (Space2 CellState))
|
||||||
|
-> Space2 CellState -> Maybe CellState
|
||||||
|
grabTemplate f s = case f s of
|
||||||
|
Nothing -> Nothing
|
||||||
|
Just x -> Just $ extract x
|
||||||
|
|
||||||
|
grabTop, grabBot, grabLeft, grabRight :: Space2 CellState -> Maybe CellState
|
||||||
|
grabTop = grabTemplate up2
|
||||||
|
grabBot = grabTemplate down2
|
||||||
|
grabLeft = grabTemplate left2
|
||||||
|
grabRight = grabTemplate right2
|
||||||
|
|
||||||
|
maycom :: (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a
|
||||||
|
maycom f g s = do
|
||||||
|
x <- f s
|
||||||
|
y <- g x
|
||||||
|
return y
|
||||||
|
|
||||||
|
grabTopLeft, grabTopRight, grabBotLeft, grabBotRight :: Space2 CellState -> Maybe CellState
|
||||||
|
grabTopLeft = grabTemplate (maycom up2 left2)
|
||||||
|
grabTopRight = grabTemplate (maycom up2 right2)
|
||||||
|
grabBotLeft = grabTemplate (maycom down2 left2)
|
||||||
|
grabBotRight = grabTemplate (maycom down2 right2)
|
||||||
|
|
||||||
|
filtJust :: [(Maybe a)] -> [a]
|
||||||
|
filtJust [] = []
|
||||||
|
filtJust (Nothing:as) = filtJust as
|
||||||
|
filtJust ((Just a):as) = a:(filtJust as)
|
||||||
|
|
||||||
|
numMatch :: CellState -> [(Maybe CellState)] -> Int
|
||||||
|
numMatch c = length . (filter (== c)) . filtJust
|
||||||
|
|
||||||
|
--------------
|
||||||
|
-- 2d rules --
|
||||||
|
--------------
|
||||||
|
|
||||||
|
conway :: Space2 CellState -> CellState
|
||||||
|
conway s = case extract s of
|
||||||
|
Rock -> Paper
|
||||||
|
Paper -> if numSci == 3 then Scissors else Paper
|
||||||
|
Scissors -> if numSci == 2 || numSci == 3 then Scissors else Paper
|
||||||
|
where
|
||||||
|
numSci = numMatch Scissors ns
|
||||||
|
ns = grabNeighbors s
|
||||||
|
|
||||||
|
rps :: Space2 CellState -> CellState
|
||||||
|
rps s
|
||||||
|
= case extract s of
|
||||||
|
Rock -> if (numNs Paper) > 2 then Paper else Rock
|
||||||
|
Paper -> if (numNs Scissors) > 2 then Scissors else Paper
|
||||||
|
Scissors -> if (numNs Rock) > 2 then Rock else Scissors
|
||||||
|
where
|
||||||
|
numNs c = numMatch c $ grabNeighbors s
|
||||||
70
src/BrickStuff.hs
Normal file
70
src/BrickStuff.hs
Normal file
|
|
@ -0,0 +1,70 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module BrickStuff where
|
||||||
|
|
||||||
|
import Automata
|
||||||
|
import Spaces.Space2
|
||||||
|
|
||||||
|
import System.Random
|
||||||
|
import Brick
|
||||||
|
import Brick.BChan (newBChan, writeBChan)
|
||||||
|
import qualified Brick.Widgets.Border as B
|
||||||
|
import qualified Brick.Widgets.Border.Style as BS
|
||||||
|
import qualified Brick.Widgets.Center as C
|
||||||
|
import qualified Graphics.Vty as V
|
||||||
|
|
||||||
|
-----------------
|
||||||
|
-- brick stuff --
|
||||||
|
-----------------
|
||||||
|
|
||||||
|
data Tick = Tick
|
||||||
|
type Name = ()
|
||||||
|
|
||||||
|
-- App definition
|
||||||
|
|
||||||
|
app :: Int -> Int -> App (Space2 CellState) Tick Name
|
||||||
|
app h w = App { appDraw = drawUI h w
|
||||||
|
, appChooseCursor = neverShowCursor
|
||||||
|
, appHandleEvent = handleEvent
|
||||||
|
, appStartEvent = return
|
||||||
|
, appAttrMap = const theMap
|
||||||
|
}
|
||||||
|
|
||||||
|
-- Handling events
|
||||||
|
|
||||||
|
theMap :: AttrMap
|
||||||
|
theMap = attrMap V.defAttr
|
||||||
|
[ (rockAttr, V.red `on` V.blue)
|
||||||
|
, (scissorsAttr, V.green `on` V.red)
|
||||||
|
, (paperAttr, V.blue `on` V.green)
|
||||||
|
]
|
||||||
|
|
||||||
|
handleEvent :: (Space2 CellState) -> BrickEvent Name Tick -> EventM Name (Next (Space2 CellState))
|
||||||
|
handleEvent g (AppEvent Tick) = continue $ step rps g
|
||||||
|
handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g
|
||||||
|
handleEvent g _ = continue g
|
||||||
|
|
||||||
|
drawUI :: Int -> Int -> Space2 CellState -> [Widget Name]
|
||||||
|
drawUI h w g = [ C.center $ drawGrid h w g ]
|
||||||
|
|
||||||
|
drawGrid :: Int -> Int -> Space2 CellState -> Widget Name
|
||||||
|
drawGrid h w g = vBox rows
|
||||||
|
where
|
||||||
|
bw = mat2 g
|
||||||
|
rows = [ hBox $ cellsInRow r | r <- bw ]
|
||||||
|
cellsInRow y = map drawCell y
|
||||||
|
|
||||||
|
drawCell :: CellState -> Widget Name
|
||||||
|
drawCell Paper = withAttr paperAttr $ str " "
|
||||||
|
drawCell Scissors = withAttr scissorsAttr $ str " "
|
||||||
|
drawCell Rock = withAttr rockAttr $ str " "
|
||||||
|
|
||||||
|
rockAttr, scissorsAttr, paperAttr :: AttrName
|
||||||
|
rockAttr = "rockAttr"
|
||||||
|
paperAttr = "paperAttr"
|
||||||
|
scissorsAttr = "scissorsAttr"
|
||||||
|
|
||||||
|
initGame :: IO (Space2 CellState)
|
||||||
|
initGame = do
|
||||||
|
rng <- getStdGen
|
||||||
|
return $ createRandSpace2 rng
|
||||||
12
src/Comonad.hs
Normal file
12
src/Comonad.hs
Normal file
|
|
@ -0,0 +1,12 @@
|
||||||
|
module Comonad where
|
||||||
|
|
||||||
|
-------------------
|
||||||
|
-- comonad class --
|
||||||
|
-------------------
|
||||||
|
|
||||||
|
class Functor w => Comonad w
|
||||||
|
where
|
||||||
|
(=>>) :: w a -> (w a -> b) -> w b
|
||||||
|
extract :: w a -> a
|
||||||
|
duplicate :: w a -> w (w a)
|
||||||
|
x =>> f = fmap f (duplicate x)
|
||||||
222
src/Main.hs
222
src/Main.hs
|
|
@ -1,212 +1,34 @@
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
--import System.Random
|
import Comonad
|
||||||
|
import Automata
|
||||||
|
import BrickStuff
|
||||||
|
import Options
|
||||||
|
import Spaces.Space2
|
||||||
|
|
||||||
|
import Brick
|
||||||
|
import Brick.BChan
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import System.Process
|
import Control.Applicative
|
||||||
import System.Random
|
import Control.Monad.IO.Class
|
||||||
import System.Console.GetOpt
|
import Control.Concurrent
|
||||||
import System.Environment(getArgs, getProgName)
|
import qualified Graphics.Vty as V
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
|
|
||||||
-------------------
|
|
||||||
-- comonad class --
|
|
||||||
-------------------
|
|
||||||
|
|
||||||
class Functor w => Comonad w
|
|
||||||
where
|
|
||||||
(=>>) :: w a -> (w a -> b) -> w b
|
|
||||||
extract :: w a -> a
|
|
||||||
duplicate :: w a -> w (w a)
|
|
||||||
x =>> f = fmap f (duplicate x)
|
|
||||||
|
|
||||||
------------
|
|
||||||
-- spaces --
|
|
||||||
------------
|
|
||||||
|
|
||||||
-- a locally focussed space
|
|
||||||
data Space t = Space [t] t [t]
|
|
||||||
|
|
||||||
-- spaces are also functors
|
|
||||||
instance Functor Space where
|
|
||||||
fmap f (Space l c r) = Space (map f l) (f c) (map f r)
|
|
||||||
|
|
||||||
-- our space is a comonad
|
|
||||||
instance Comonad Space where
|
|
||||||
-- duplicate will create a new space where
|
|
||||||
-- the focussed element is our original space
|
|
||||||
-- and each side is increasingly shifted copies
|
|
||||||
-- in that direction
|
|
||||||
duplicate w =
|
|
||||||
Space (tail $ iterate left w)
|
|
||||||
w
|
|
||||||
(tail $ iterate right w)
|
|
||||||
-- extract simply returns the focussed element
|
|
||||||
extract (Space _ c _) = c
|
|
||||||
|
|
||||||
-- functions for moving the point
|
|
||||||
-- of locality.
|
|
||||||
-- todo: question the empty list cases
|
|
||||||
-- most spaces should be infinite
|
|
||||||
right :: Space t -> Space t
|
|
||||||
right s@(Space l c []) = s
|
|
||||||
right (Space l c (r:rs)) = Space (c:l) r rs
|
|
||||||
|
|
||||||
left :: Space t -> Space t
|
|
||||||
left s@(Space [] c r) = s
|
|
||||||
left (Space (l:ls) c r) = Space ls l (c:r)
|
|
||||||
|
|
||||||
-- bound will take an infinite space
|
|
||||||
-- and bound it by i and j on each side
|
|
||||||
-- (not including the focus) and
|
|
||||||
-- turn it into a list for printing
|
|
||||||
bound :: Int -> Int -> Space t -> [t]
|
|
||||||
bound i j (Space l c r) = (reverse (take i l)) ++ (c:(take j r))
|
|
||||||
|
|
||||||
-- boundw works as above, but the
|
|
||||||
-- entire list will be the size
|
|
||||||
-- given
|
|
||||||
boundw :: Int -> Space t -> [t]
|
|
||||||
boundw n = bound (x-m) x
|
|
||||||
where
|
|
||||||
o = if odd n then 1 else 0
|
|
||||||
m = if even n then 1 else 0
|
|
||||||
x = (n - o) `div` 2
|
|
||||||
|
|
||||||
-----------------------
|
|
||||||
-- cellular automata --
|
|
||||||
-----------------------
|
|
||||||
|
|
||||||
-- the states our cells can be in
|
|
||||||
-- may need to provide an ordering
|
|
||||||
-- may need to generalise the number
|
|
||||||
-- of states
|
|
||||||
data CellState = Alive | Dead
|
|
||||||
deriving Eq
|
|
||||||
|
|
||||||
-- how the states are displayed on screen
|
|
||||||
-- this should probably be input to a function
|
|
||||||
-- rather than hardcoded
|
|
||||||
instance Show CellState
|
|
||||||
where
|
|
||||||
show Alive = "█"
|
|
||||||
show Dead = " "
|
|
||||||
|
|
||||||
-- a rule stating how a cell is determined
|
|
||||||
rule :: Space CellState -> CellState
|
|
||||||
rule (Space (l:_) _ (r:_))
|
|
||||||
| l == r = Dead
|
|
||||||
| otherwise = Alive
|
|
||||||
|
|
||||||
-- a second rule for example
|
|
||||||
rule2 :: Space CellState -> CellState
|
|
||||||
rule2 (Space (l1:l2:_) m (r1:r2:_))
|
|
||||||
| m == Alive && numAlive == 1 = Dead
|
|
||||||
| m == Alive && numAlive == 4 = Dead
|
|
||||||
| m == Dead && numAlive == 3 = Alive
|
|
||||||
| otherwise = m
|
|
||||||
where
|
|
||||||
ns = [l1, l2, r1, r2]
|
|
||||||
numAlive = length $ filter (== Alive) ns
|
|
||||||
|
|
||||||
rule3 :: Space CellState -> CellState
|
|
||||||
rule3 (Space (l:_) m (r:_))
|
|
||||||
| l == r = m
|
|
||||||
| otherwise = if m == Alive then Dead else Alive
|
|
||||||
|
|
||||||
-- take a space and a rule and
|
|
||||||
-- return the next space
|
|
||||||
step :: (Space t -> t) -> Space t -> Space t
|
|
||||||
step f w = w =>> f
|
|
||||||
|
|
||||||
---------------
|
|
||||||
-- rng stuff --
|
|
||||||
---------------
|
|
||||||
|
|
||||||
-- takes a generator and returns
|
|
||||||
-- an infinite list of bools
|
|
||||||
ilobs :: StdGen -> [Bool]
|
|
||||||
ilobs rng = b : (ilobs r)
|
|
||||||
where
|
|
||||||
(b,r) = random rng
|
|
||||||
|
|
||||||
-----------------
|
|
||||||
-- gross io bs --
|
|
||||||
-----------------
|
|
||||||
|
|
||||||
-- everything below this line deals with
|
|
||||||
-- input/output, and is therefore gross
|
|
||||||
-- i will clean this up one day, but it
|
|
||||||
-- hurts my soul.
|
|
||||||
|
|
||||||
------------------------
|
|
||||||
-- command line flags --
|
|
||||||
------------------------
|
|
||||||
|
|
||||||
-- structure containing the programs options
|
|
||||||
data Options = Options
|
|
||||||
{ optWidth :: Int
|
|
||||||
, optGenerations :: Int
|
|
||||||
} deriving Show
|
|
||||||
|
|
||||||
-- the default options for the program
|
|
||||||
-- the width and generations are injected
|
|
||||||
-- and intended to be gotten at runtime
|
|
||||||
-- to match the window dimensions
|
|
||||||
defaultOptions :: Int -> Int -> Options
|
|
||||||
defaultOptions w h = Options
|
|
||||||
{ optWidth = w
|
|
||||||
, optGenerations = h
|
|
||||||
}
|
|
||||||
|
|
||||||
-- the avaliable options
|
|
||||||
options :: [OptDescr (Options -> Options)]
|
|
||||||
options =
|
|
||||||
[ Option ['w'] ["width"]
|
|
||||||
(ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
|
|
||||||
"term width"
|
|
||||||
, Option ['g'] ["generations"]
|
|
||||||
(ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS")
|
|
||||||
"time steps to simulate"
|
|
||||||
]
|
|
||||||
|
|
||||||
-- parse the options into the structure
|
|
||||||
-- erroring if encountering a flag not known to us
|
|
||||||
parseArgs :: IO Options
|
|
||||||
parseArgs = do
|
|
||||||
argv <- getArgs
|
|
||||||
progName <- getProgName
|
|
||||||
tw <- readProcess "tput" [ "cols" ] ""
|
|
||||||
th <- readProcess "tput" [ "lines" ] ""
|
|
||||||
case getOpt RequireOrder options argv of
|
|
||||||
(opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
|
|
||||||
(_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
|
|
||||||
where
|
|
||||||
header = "Usage: " ++ progName ++ " [OPTION...]"
|
|
||||||
helpMessage = usageInfo header options
|
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
-- main loop --
|
-- main loop --
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
-- simply print the current space, then recurse to the next
|
|
||||||
runAutomata :: Space CellState -> Int -> Int -> IO ()
|
|
||||||
runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s
|
|
||||||
runAutomata s n w = do
|
|
||||||
putStrLn $ concat $ map show $ boundw w s
|
|
||||||
runAutomata (step rule s) (n - 1) w
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
options <- parseArgs
|
options <- parseArgs
|
||||||
rng <- getStdGen
|
|
||||||
let cs = map (\x -> if x then Alive else Dead) $ ilobs rng
|
|
||||||
let w = (optWidth options)
|
let w = (optWidth options)
|
||||||
let h = (optGenerations options)
|
let h = (optHeight options)
|
||||||
let wh = (w + 1) `div` 2
|
chan <- newBChan 1
|
||||||
let m = head cs
|
forkIO $ forever $ do
|
||||||
let l = take wh $ drop 1 cs
|
writeBChan chan Tick
|
||||||
let r = take wh $ drop wh $ drop 1 cs
|
threadDelay $ (optTime options) * 10000
|
||||||
let s = Space (l ++ (repeat Dead)) m (r ++ (repeat Dead))
|
g <- initGame
|
||||||
-- non-random starting position for rule3 (the serpinski triangle)
|
let buildVty = V.mkVty V.defaultConfig
|
||||||
--let s = Space (repeat Dead) Alive (repeat Dead)
|
initialVty <- buildVty
|
||||||
runAutomata s h w
|
void $ customMain initialVty buildVty (Just chan) (app h w) (clamp2 w h g)
|
||||||
|
|
||||||
|
|
|
||||||
61
src/Options.hs
Normal file
61
src/Options.hs
Normal file
|
|
@ -0,0 +1,61 @@
|
||||||
|
module Options where
|
||||||
|
|
||||||
|
import System.Environment
|
||||||
|
import System.Console.GetOpt
|
||||||
|
import System.Process
|
||||||
|
|
||||||
|
------------------------
|
||||||
|
-- command line flags --
|
||||||
|
------------------------
|
||||||
|
|
||||||
|
-- structure containing the programs options
|
||||||
|
data Options = Options
|
||||||
|
{ optWidth :: Int
|
||||||
|
, optGenerations :: Int
|
||||||
|
, optHeight :: Int
|
||||||
|
, optTime :: Int
|
||||||
|
} deriving Show
|
||||||
|
|
||||||
|
-- the default options for the program
|
||||||
|
-- the width and generations are injected
|
||||||
|
-- and intended to be gotten at runtime
|
||||||
|
-- to match the window dimensions
|
||||||
|
defaultOptions :: Int -> Int -> Options
|
||||||
|
defaultOptions w h = Options
|
||||||
|
{ optWidth = w
|
||||||
|
, optGenerations = 40
|
||||||
|
, optHeight = h
|
||||||
|
, optTime = 7
|
||||||
|
}
|
||||||
|
|
||||||
|
-- the avaliable options
|
||||||
|
options :: [OptDescr (Options -> Options)]
|
||||||
|
options =
|
||||||
|
[ Option ['w'] ["width"]
|
||||||
|
(ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
|
||||||
|
"term width"
|
||||||
|
, Option ['g'] ["generations"]
|
||||||
|
(ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS")
|
||||||
|
"time steps to simulate"
|
||||||
|
, Option ['h'] ["height"]
|
||||||
|
(ReqArg (\t opts -> opts { optHeight = (read t) }) "HEIGHT")
|
||||||
|
"term height"
|
||||||
|
, Option ['t'] ["time"]
|
||||||
|
(ReqArg (\t opts -> opts { optTime = (read t) }) "TIME")
|
||||||
|
"delay time"
|
||||||
|
]
|
||||||
|
|
||||||
|
-- parse the options into the structure
|
||||||
|
-- erroring if encountering a flag not known to us
|
||||||
|
parseArgs :: IO Options
|
||||||
|
parseArgs = do
|
||||||
|
argv <- getArgs
|
||||||
|
progName <- getProgName
|
||||||
|
tw <- readProcess "tput" [ "cols" ] ""
|
||||||
|
th <- readProcess "tput" [ "lines" ] ""
|
||||||
|
case getOpt RequireOrder options argv of
|
||||||
|
(opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
|
||||||
|
(_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
|
||||||
|
where
|
||||||
|
header = "Usage: " ++ progName ++ " [OPTION...]"
|
||||||
|
helpMessage = usageInfo header options
|
||||||
78
src/Spaces/Space1.hs
Normal file
78
src/Spaces/Space1.hs
Normal file
|
|
@ -0,0 +1,78 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
|
module Spaces.Space1 where
|
||||||
|
|
||||||
|
import Comonad
|
||||||
|
|
||||||
|
import System.Random
|
||||||
|
import Control.DeepSeq
|
||||||
|
import GHC.Generics
|
||||||
|
|
||||||
|
-- a locally focussed space
|
||||||
|
data Space t = Space [t] t [t]
|
||||||
|
deriving (Generic, Generic1, Show)
|
||||||
|
|
||||||
|
-- allowing strict evaluation of a space
|
||||||
|
instance NFData a => NFData (Space a)
|
||||||
|
instance NFData1 Space
|
||||||
|
|
||||||
|
-- spaces are also functors
|
||||||
|
instance Functor Space where
|
||||||
|
fmap f (Space l c r) = Space (map f l) (f c) (map f r)
|
||||||
|
|
||||||
|
-- moving a space focus right
|
||||||
|
right :: Space t -> Maybe (Space t)
|
||||||
|
right (Space _ _ []) = Nothing
|
||||||
|
right (Space l c (r:rs)) = Just $ Space (c:l) r rs
|
||||||
|
|
||||||
|
-- moving a space's focus left
|
||||||
|
left :: Space t -> Maybe (Space t)
|
||||||
|
left (Space [] _ _) = Nothing
|
||||||
|
left (Space (l:ls) c r) = Just $ Space ls l (c:r)
|
||||||
|
|
||||||
|
-- iterate until we reach an edge
|
||||||
|
finterate :: (a -> Maybe a) -> a -> [a]
|
||||||
|
finterate f x = case (f x) of
|
||||||
|
Nothing -> []
|
||||||
|
Just y -> y : finterate f y
|
||||||
|
|
||||||
|
-- our space is a comonad
|
||||||
|
instance Comonad Space where
|
||||||
|
-- duplicate creats a meta space
|
||||||
|
duplicate w =
|
||||||
|
Space (finterate left w)
|
||||||
|
w
|
||||||
|
(finterate right w)
|
||||||
|
-- extract simply returns the focussed element
|
||||||
|
extract (Space _ c _) = c
|
||||||
|
|
||||||
|
-- clamp an infinite space to a finite space
|
||||||
|
-- relative to center
|
||||||
|
clampRel :: Int -> Int -> Space t -> Space t
|
||||||
|
clampRel x y (Space l m r) = Space (take x l) m (take y r)
|
||||||
|
|
||||||
|
-- as above, but with a set width
|
||||||
|
-- if the width is even, we need to take one less from the left
|
||||||
|
clamp :: Int -> Space t -> Space t
|
||||||
|
clamp w (Space l m r) = Space (take ln l) m (take h r)
|
||||||
|
where
|
||||||
|
h = w `div` 2
|
||||||
|
ln = h - (if even w then 1 else 0)
|
||||||
|
|
||||||
|
-- materialises a space, will hang if infinite
|
||||||
|
mat :: Space t -> [t]
|
||||||
|
mat (Space l m r) = (reverse l) ++ (m:r)
|
||||||
|
|
||||||
|
-- as above, but clamps to a given size first
|
||||||
|
matn :: Int -> Space t -> [t]
|
||||||
|
matn n = mat . (clamp n)
|
||||||
|
|
||||||
|
-- create a randomly filled space
|
||||||
|
createRandSpace :: Random a => StdGen -> Space a
|
||||||
|
createRandSpace rng =
|
||||||
|
Space (tail $ map snd $ iterate f (r1, (fst (random rng))))
|
||||||
|
(fst (random rng))
|
||||||
|
(tail $ map snd $ iterate f (r2, (fst (random rng))))
|
||||||
|
where
|
||||||
|
f (r,b) = let (nb,nr) = (random r) in (nr,nb)
|
||||||
|
(r1,r2) = split rng
|
||||||
122
src/Spaces/Space2.hs
Normal file
122
src/Spaces/Space2.hs
Normal file
|
|
@ -0,0 +1,122 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
|
module Spaces.Space2 where
|
||||||
|
|
||||||
|
import Comonad
|
||||||
|
import Spaces.Space1
|
||||||
|
|
||||||
|
import System.Random
|
||||||
|
import Data.Maybe
|
||||||
|
import Control.DeepSeq
|
||||||
|
import GHC.Generics
|
||||||
|
|
||||||
|
-- a nested space
|
||||||
|
data Space2 t = Space2 [(Space t)] (Space t) [(Space t)]
|
||||||
|
deriving (Generic, Generic1, Show)
|
||||||
|
|
||||||
|
-- generating strict data instances
|
||||||
|
instance NFData a => NFData (Space2 a)
|
||||||
|
instance NFData1 Space2
|
||||||
|
|
||||||
|
-- we can fmap into this structure by recursively fmapping
|
||||||
|
-- the inner spaces
|
||||||
|
instance Functor Space2 where
|
||||||
|
fmap f (Space2 u m d) =
|
||||||
|
Space2 (fmap (fmap f) u) (fmap f m) (fmap (fmap f) d)
|
||||||
|
|
||||||
|
-- map a partial function, converting to non maybe values
|
||||||
|
fintermap :: (a -> Maybe a) -> [a] -> [a]
|
||||||
|
fintermap _ [] = []
|
||||||
|
fintermap f (a:as) = case f a of
|
||||||
|
Nothing -> []
|
||||||
|
Just y -> y : fintermap f as
|
||||||
|
|
||||||
|
f :: ((Space2 a) -> Maybe (Space2 a)) -> Space (Space2 a) -> Maybe (Space (Space2 a))
|
||||||
|
f g (Space l m r) = case (g m) of
|
||||||
|
Nothing -> Nothing
|
||||||
|
Just y -> Just $ Space (fintermap g l) y (fintermap g r)
|
||||||
|
|
||||||
|
-- comonad instance for our 2d space
|
||||||
|
instance Comonad Space2 where
|
||||||
|
-- to duplicate we must recursively duplicate in all directions
|
||||||
|
-- the focussed space becomes the whole space, with left and right
|
||||||
|
-- mapped to each side.
|
||||||
|
-- to do the up and down lists, each needs to be the middle space
|
||||||
|
-- mapped up and down as far as we can.
|
||||||
|
-- up2 and down2 will return Nothing when they cant go further
|
||||||
|
duplicate w =
|
||||||
|
Space2 (finterate (f up2) dm) dm (finterate (f down2) dm)
|
||||||
|
where
|
||||||
|
dm = Space (finterate left2 w) w (finterate right2 w)
|
||||||
|
-- to extract we simply recursively extract
|
||||||
|
extract (Space2 _ m _) = extract m
|
||||||
|
|
||||||
|
-- directional moving of focus
|
||||||
|
up2 :: Space2 t -> Maybe (Space2 t)
|
||||||
|
up2 (Space2 [] _ _) = Nothing
|
||||||
|
up2 (Space2 (u:us) m d) = Just $ Space2 us u (m:d)
|
||||||
|
|
||||||
|
down2 :: Space2 t -> Maybe (Space2 t)
|
||||||
|
down2 (Space2 _ _ []) = Nothing
|
||||||
|
down2 (Space2 u m (d:ds)) = Just $ Space2 (m:u) d ds
|
||||||
|
|
||||||
|
noLeft :: Space t -> Bool
|
||||||
|
noLeft (Space [] _ _) = True
|
||||||
|
noLeft _ = False
|
||||||
|
|
||||||
|
noRight :: Space t -> Bool
|
||||||
|
noRight (Space _ _ []) = True
|
||||||
|
noRight _ = False
|
||||||
|
|
||||||
|
-- left and right require mapping further
|
||||||
|
-- we are assuming things are rectangular (maybe a bad idea?)
|
||||||
|
left2 :: Space2 t -> Maybe (Space2 t)
|
||||||
|
left2 (Space2 u m d) =
|
||||||
|
if check
|
||||||
|
then Nothing
|
||||||
|
else Just $ Space2 (fmap (f . left) u) (f $ left m) (fmap (f . left) d)
|
||||||
|
where
|
||||||
|
check = noLeft m
|
||||||
|
f l = fromJust l
|
||||||
|
|
||||||
|
right2 :: Space2 t -> Maybe (Space2 t)
|
||||||
|
right2 (Space2 u m d) =
|
||||||
|
if check
|
||||||
|
then Nothing
|
||||||
|
else Just $ Space2 (fmap (f . right) u) (f $ right m) (fmap (f . right) d)
|
||||||
|
where
|
||||||
|
check = noRight m
|
||||||
|
f l = fromJust l
|
||||||
|
|
||||||
|
-- clamp as we do in 1d Spaces
|
||||||
|
clampRel2 :: Int -> Int -> Int -> Int -> Space2 t -> Space2 t
|
||||||
|
clampRel2 w x y z (Space2 u m d) = Space2 (take w $ fmap f u) (f m) (take x $ fmap f d)
|
||||||
|
where
|
||||||
|
f = clampRel y z
|
||||||
|
|
||||||
|
clamp2 :: Int -> Int -> Space2 t -> Space2 t
|
||||||
|
clamp2 w h = clampRel2 nu nd nl nr
|
||||||
|
where
|
||||||
|
nu = h `div` 2
|
||||||
|
nd = nu - (if even h then 1 else 0)
|
||||||
|
nr = w `div` 2
|
||||||
|
nl = nr - (if even w then 1 else 0)
|
||||||
|
|
||||||
|
mat2 :: Space2 t -> [[t]]
|
||||||
|
mat2 (Space2 u m d) = (reverse (fmap mat u)) ++ ((mat m):(fmap mat d))
|
||||||
|
|
||||||
|
matn2 :: Int -> Int -> Space2 t -> [[t]]
|
||||||
|
matn2 w h = mat2 . (clamp2 w h)
|
||||||
|
|
||||||
|
step :: Comonad w => (w t -> t) -> w t -> w t
|
||||||
|
step f w = w =>> f
|
||||||
|
|
||||||
|
-- create a randomly filled space
|
||||||
|
createRandSpace2 :: Random a => StdGen -> Space2 a
|
||||||
|
createRandSpace2 rng =
|
||||||
|
Space2 (tail $ map snd $ iterate f (r1, (createRandSpace r1)))
|
||||||
|
(createRandSpace rng)
|
||||||
|
(tail $ map snd $ iterate f (r2, (createRandSpace r2)))
|
||||||
|
where
|
||||||
|
f (r,s) = let (nr1,nr2) = split r in (nr2, (createRandSpace nr1))
|
||||||
|
(r1,r2) = split rng
|
||||||
Loading…
Reference in a new issue