├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .travis.yml ├── CHANGES ├── LICENSE ├── README.markdown ├── Setup.hs ├── active.cabal ├── cabal.project ├── diagrams ├── Makefile ├── src_Active_activeFDia.svg ├── src_Active_activeIDia.svg ├── src_Active_alwaysDia.svg ├── src_Active_atDurationsDia.svg ├── src_Active_backwardsDia.svg ├── src_Active_cos'Dia.svg ├── src_Active_cosRampDia.svg ├── src_Active_cutDia.svg ├── src_Active_delayDia.svg ├── src_Active_discreteNEDia.svg ├── src_Active_durDia.svg ├── src_Active_exampleCombDia.svg ├── src_Active_exampleDia.svg ├── src_Active_instantDia.svg ├── src_Active_intervalDia.svg ├── src_Active_intervalDia2.svg ├── src_Active_lastingDia.svg ├── src_Active_matchDurationDia.svg ├── src_Active_movieDia.svg ├── src_Active_omitDia.svg ├── src_Active_pamfDia.svg ├── src_Active_parIDia.svg ├── src_Active_parUDia.svg ├── src_Active_rampDia.svg ├── src_Active_samplesDia.svg ├── src_Active_seqADia.svg ├── src_Active_seqLDia.svg ├── src_Active_seqMDia.svg ├── src_Active_seqMMaxDia.svg ├── src_Active_seqRDia.svg ├── src_Active_sin'Dia.svg ├── src_Active_sliceDia.svg ├── src_Active_sliceDia2.svg ├── src_Active_snapshotDia.svg ├── src_Active_stackAtDefDia.svg ├── src_Active_stackAtDia.svg ├── src_Active_stackAtDia2.svg ├── src_Active_stackDia.svg ├── src_Active_stitchDia.svg ├── src_Active_stretch'Dia.svg ├── src_Active_stretchDia.svg ├── src_Active_stretchToDia.svg ├── src_Active_testDia.svg ├── src_Active_uiDia.svg ├── src_Data_Active_backwardsDia.svg ├── src_Data_Active_clampAfterDia.svg ├── src_Data_Active_clampBeforeDia.svg ├── src_Data_Active_clampDia.svg ├── src_Data_Active_trimAfterDia.svg ├── src_Data_Active_trimBeforeDia.svg ├── src_Data_Active_trimDia.svg ├── src_Data_Active_uiDia.svg └── ui.hs ├── example ├── Animation.hs ├── CRT.hs ├── CRT2.hs ├── CRTAccum.hs ├── Clock.hs └── README.md ├── explore ├── RandomQ.hs └── Sticky.hs ├── old-semantics ├── ActiveDiagrams.hs ├── FARM │ ├── A.png │ ├── ActiveDiagrams.hs │ ├── C.png │ ├── D.png │ ├── Shake.hs │ ├── abstract.bib │ ├── abstract.lhs │ ├── diagrams-latex.sty │ └── sigplanconf.cls ├── IApplicative.hs ├── LICENSE ├── Setup.hs ├── Shake.hs ├── active-semantics.bib ├── active-semantics.cabal ├── active-semantics.lhs └── old │ ├── ActiveDiagrams.hs │ ├── LICENSE │ ├── Setup.hs │ ├── Shake.hs │ ├── active-semantics.bib │ ├── active-semantics.cabal │ ├── active-semantics.lhs │ └── diagrams │ ├── active-semantics-diagrams-latex-fig1.hs │ ├── active-semantics-diagrams-latex-fig10.hs │ ├── active-semantics-diagrams-latex-fig11.hs │ ├── active-semantics-diagrams-latex-fig12.hs │ ├── active-semantics-diagrams-latex-fig13.hs │ ├── active-semantics-diagrams-latex-fig2.hs │ ├── active-semantics-diagrams-latex-fig3.hs │ ├── active-semantics-diagrams-latex-fig4.hs │ ├── active-semantics-diagrams-latex-fig5.hs │ ├── active-semantics-diagrams-latex-fig6.hs │ ├── active-semantics-diagrams-latex-fig7.hs │ ├── active-semantics-diagrams-latex-fig8.hs │ └── active-semantics-diagrams-latex-fig9.hs ├── paper └── haskell2020 │ ├── ACM-Reference-Format.bst │ ├── Shake.hs │ ├── acmart.cls │ ├── acmart.pdf │ ├── active.lhs │ ├── build.sh │ ├── diagrams-latex.sty │ ├── notes.txt │ └── stack.yaml ├── src ├── Active.hs └── Active │ ├── Duration.hs │ └── Ray.hs ├── stack.yaml └── test ├── Laws.hs └── active-doctest.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virthualenv 9 | *~ 10 | .hsenv_* 11 | dist_* 12 | dist-* 13 | cabal.project.local 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | .stack-work/ 17 | codex.tags 18 | .ghc.environment.* 19 | history 20 | TAGS 21 | .diagrams_cache 22 | .shake.database 23 | *.errors 24 | *.pdf 25 | Shake 26 | *.aux 27 | *.log 28 | *.ptb 29 | *.tex 30 | *.bbl 31 | *.blg 32 | *.cut 33 | *.out 34 | ActiveDiagrams 35 | semantics/diagrams/* 36 | semantics/FARM/diagrams/* 37 | .diagrams-cache 38 | .stack-work 39 | stack.yaml.lock 40 | .shake 41 | 42 | paper/haskell2020/diagrams/* 43 | 44 | example/Animation 45 | example/out/* 46 | 47 | *.gif 48 | *.exe 49 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | env: 4 | matrix: 5 | - GHCVER=7.8.4 CABALVER=1.18 SKIP_TESTS=true SKIP_HADDOCK=true 6 | - GHCVER=7.10.3 CABALVER=1.22 SKIP_TESTS=true SKIP_HADDOCK=true 7 | - GHCVER=8.0.2 CABALVER=1.24 8 | - GHCVER=8.2.2 CABALVER=2.0 9 | - GHCVER=8.4.3 CABALVER=2.2 10 | - GHCVER=head CABALVER=head 11 | 12 | matrix: 13 | allow_failures: 14 | - env: GHCVER=head CABALVER=head 15 | 16 | before_install: 17 | - git clone http://github.com/diagrams/diagrams-travis travis 18 | - source travis/scripts/set_env.sh 19 | - ./travis/scripts/before_install.sh 20 | 21 | install: ./travis/scripts/install.sh 22 | 23 | script: ./travis/scripts/script.sh 24 | 25 | notifications: 26 | email: false 27 | irc: 28 | channels: 29 | - "irc.freenode.org#diagrams" 30 | skip_join: true 31 | template: 32 | - "\x0313active\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" 33 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | ## [0.2.0.13](https://github.com/diagrams/active/tree/v0.2.0.13) (2017-05-16) 2 | 3 | - fix for `lens-4.15.2` 4 | 5 | Hackage revisions: 6 | 7 | - r1: 8 | - allow `base-4.10` (GHC 8.2) 9 | - r2: 10 | - allow `QuickCheck-2.10` 11 | - r3: 12 | - allow `lens-4.16` 13 | - allow `QuickCheck-2.11` 14 | - r4: 15 | - allow `base-4.11` (GHC 8.4) 16 | 17 | ## [0.2.0.12](https://github.com/diagrams/active/tree/v0.2.0.12) (2016-10-14) 18 | 19 | - allow `lens-4.15` 20 | 21 | Included in revision 1 on Hackage: 22 | - allow `semigroupoids-5.2` 23 | 24 | ## [v0.2.0.11](https://github.com/diagrams/active/tree/v0.2.0.11) (2016-08-01) 25 | 26 | - update test suite for `QuickCheck-2.9` 27 | 28 | ## [v0.2.0.10](https://github.com/diagrams/active/tree/v0.2.0.10) (2016-07-01) 29 | 30 | - allow `semigroupoids-5.1` 31 | 32 | ## [v0.2.0.9](https://github.com/diagrams/active/tree/v0.2.0.9) (2016-05-01) 33 | 34 | - allow `lens-4.14` 35 | 36 | ## [v0.2.0.8](https://github.com/diagrams/active/tree/v0.2.0.8) (2015-11-10) 37 | 38 | - allow `semigroups-0.18` 39 | 40 | ## [v0.2.0.7](https://github.com/diagrams/active/tree/v0.2.0.7) (2015-11-09) 41 | 42 | - fix image links in documentation 43 | 44 | ## [v0.2.0.6](https://github.com/diagrams/active/tree/v0.2.0.6) (2015-09-17) 45 | 46 | - allow `semigroups-0.17` in test suite 47 | 48 | ## [v0.2.0.5](https://github.com/diagrams/active/tree/v0.2.0.5) (2015-09-15) 49 | 50 | - allow `semigroups-0.17` 51 | 52 | [Full Changelog](https://github.com/diagrams/active/compare/v0.2.0.4...v0.2.0.5) 53 | 54 | ## [v0.2.0.4](https://github.com/diagrams/active/tree/v0.2.0.4) (2015-07-19) 55 | 56 | [Full Changelog](https://github.com/diagrams/active/compare/v0.2.0.3...v0.2.0.4) 57 | 58 | ## [v0.2.0.3](https://github.com/diagrams/active/tree/v0.2.0.3) (2015-05-26) 59 | 60 | [Full Changelog](https://github.com/diagrams/active/compare/v0.2.0.2...v0.2.0.3) 61 | 62 | 0.2.0.2 (30 April 2015) 63 | ----------------------- 64 | 65 | - reinstate `toTime`, `fromTime`, `toDuration`, `fromDuration` 66 | which got accidentally removed in 0.2 67 | 68 | 0.2.0.1 (22 April 2015) 69 | ----------------------- 70 | 71 | - allow `lens-4.9` and `QuickCheck-2.8` in test suite 72 | 73 | 0.2.0.0 (19 April 2015) 74 | ----------------------- 75 | 76 | - switch from `vector-space` to `linear` 77 | - allow `lens-4.9` 78 | - allow `base-4.8` 79 | 80 | 0.1.0.18 (22 Feb 2015) 81 | ---------------------- 82 | 83 | - Allow `semigroupoids-4.3` 84 | - Allow `vector-space-0.9` 85 | 86 | 0.1.0.17 (03 Dec 2014) 87 | ---------------------- 88 | 89 | - Allow `semigroups-0.16` 90 | 91 | 0.1.0.16 (2 June 2014) 92 | ---------------------- 93 | 94 | * correct version constraint problems with previous release 95 | 96 | 0.1.0.15 (28 May 2014) (BROKEN) 97 | ------------------------------- 98 | 99 | * allow semigroups-0.15 100 | 101 | 0.1.0.14 (15 May 2014) 102 | ------------------------ 103 | 104 | * allow semigroups-0.14 105 | 106 | 0.1.0.13 (20 April 2014) 107 | ------------------------ 108 | 109 | * allow semigroups-0.13 in test suite too 110 | 111 | 0.1.0.12 (10 April 2014) 112 | ------------------------ 113 | 114 | * allow semigroups-0.13 115 | 116 | 0.1.0.11 (9 April 2014) 117 | ----------------------- 118 | 119 | * allow QuickCheck-2.7 120 | 121 | 0.1.0.10 (27 November 2013) 122 | --------------------------- 123 | 124 | * allow semigroups-0.12 125 | 126 | 0.1.0.9 (2 November 2013) 127 | ------------------------- 128 | 129 | * allow array-0.5 130 | 131 | 0.1.0.7 (27 September 2013) 132 | --------------------------- 133 | 134 | * allow semigroups-0.11 135 | 136 | 0.1.0.6 (16 July 2013) 137 | ---------------------- 138 | 139 | * bump upper bound to allow semigroupoids-3.1 140 | 141 | 0.1.0.5 (16 July 2013) 142 | ---------------------- 143 | 144 | * bump upper bound to allow base-4.7 145 | 146 | 0.1.0.4 (19 March 2013) 147 | ----------------------- 148 | 149 | * bump upper bound to allow QuickCheck-2.6 150 | 151 | 0.1.0.3 152 | 153 | - bump semigroups upper bound to allow semigroups-0.9 154 | 155 | 0.1.0.2 156 | 157 | * Bump dependency upper bounds: 158 | - semigroupoids < 3.1 159 | - base < 4.7 160 | - QuickCheck < 2.6 161 | * Updates to .cabal file 162 | 163 | 0.1.0.0: 9 March 2012 164 | 165 | Initial release. 166 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2015, active team: 2 | 3 | Andy Gill 4 | Ben Gamari 5 | Bollu 6 | Brent Yorgey 7 | Christopher Chalmers 8 | Daniel Bergey 9 | Jeffrey Rosenbluth 10 | Ryan Scott 11 | 12 | All rights reserved. 13 | 14 | Redistribution and use in source and binary forms, with or without 15 | modification, are permitted provided that the following conditions are met: 16 | 17 | * Redistributions of source code must retain the above copyright 18 | notice, this list of conditions and the following disclaimer. 19 | 20 | * Redistributions in binary form must reproduce the above 21 | copyright notice, this list of conditions and the following 22 | disclaimer in the documentation and/or other materials provided 23 | with the distribution. 24 | 25 | * Neither the name of Brent Yorgey nor the names of other 26 | contributors may be used to endorse or promote products derived 27 | from this software without specific prior written permission. 28 | 29 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 30 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 31 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 32 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 33 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 34 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 35 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 36 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 37 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 38 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 39 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 40 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![Build Status](https://secure.travis-ci.org/diagrams/active.png)](http://travis-ci.org/diagrams/active) 2 | 3 | This package defines an `Active` abstraction for time-varying values 4 | with finite start and end times. It is used for describing animations 5 | within the [diagrams framework](http://projects.haskell.org/diagrams). 6 | 7 | To install, 8 | 9 | cabal install active 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Extra.Doctest (defaultMainWithDoctests) 4 | 5 | main :: IO () 6 | main = defaultMainWithDoctests "doctests" 7 | -------------------------------------------------------------------------------- /active.cabal: -------------------------------------------------------------------------------- 1 | name: active 2 | version: 0.3 3 | synopsis: An EDSL for time-varying values. 4 | description: active is a small EDSL for building continuous, 5 | time-varying values 6 | of arbitrary type. It is particularly useful for 7 | building media such as animations, audio clips, 8 | and the like, but it is often useful to have 9 | other values that vary over time (vectors, 10 | colors, filters, volume levels...) and be able to 11 | create and use them in the service of 12 | constructing time-varying media. 13 | license: BSD3 14 | license-file: LICENSE 15 | author: Brent Yorgey 16 | maintainer: byorgey@gmail.com 17 | copyright: (c) 2011-2017 Brent Yorgey 18 | category: Data 19 | build-type: Custom 20 | cabal-version: 1.18 21 | extra-doc-files: CHANGES, README.markdown, diagrams/*.svg 22 | bug-reports: https://github.com/diagrams/active/issues 23 | 24 | tested-with: 25 | GHC == 9.6.1 26 | GHC == 9.4.4 27 | GHC == 9.2.7 28 | GHC == 9.0.2 29 | GHC == 8.10.7 30 | GHC == 8.8.4 31 | GHC == 8.6.5 32 | GHC == 8.4.4 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/diagrams/active.git 37 | 38 | custom-setup 39 | setup-depends: 40 | base >= 4.7 && < 5, 41 | Cabal < 4, 42 | cabal-doctest >= 1 && <1.1 43 | 44 | library 45 | exposed-modules: Active, 46 | Active.Duration 47 | other-modules: Active.Ray 48 | other-extensions: FlexibleContexts, 49 | FlexibleInstances, 50 | GADTSyntax, 51 | KindSignatures 52 | build-depends: base >= 4.11 && < 5, 53 | bifunctors >= 5.4 && < 5.7, 54 | semigroups >= 0.1 && < 0.21, 55 | vector >= 0.10 && < 0.14, 56 | linear >= 1.14 && < 1.23 57 | hs-source-dirs: src 58 | default-language: Haskell2010 59 | 60 | test-suite doctests 61 | type: exitcode-stdio-1.0 62 | main-is: active-doctest.hs 63 | build-depends: base, 64 | doctest < 1 65 | hs-source-dirs: test 66 | default-language: Haskell2010 67 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: *.cabal 2 | -------------------------------------------------------------------------------- /diagrams/Makefile: -------------------------------------------------------------------------------- 1 | all : ui.png clamp.png clampBefore.png clampAfter.png trim.png trimBefore.png trimAfter.png backwards.png 2 | 3 | .SECONDARY : 4 | 5 | %.exe : %.hs 6 | ghc --make $< -o $@ 7 | 8 | %.png : ui.exe 9 | ./ui.exe -w 200 -h 200 -o $@ --selection=$* 10 | 11 | clean : 12 | rm -f *.exe *.o *.hi *.pdf *.png *~ *.errors 13 | 14 | exp : all 15 | scp *.png byorgey@eniac.seas.upenn.edu:public_html/hosted/ -------------------------------------------------------------------------------- /diagrams/src_Active_activeFDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_activeIDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_alwaysDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_cos'Dia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_cosRampDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_discreteNEDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_durDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_exampleDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_instantDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_intervalDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_intervalDia2.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_lastingDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_pamfDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_rampDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_samplesDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_seqLDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_seqMDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_seqRDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_sin'Dia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_stretchToDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_testDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Active_uiDia.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_backwardsDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_clampAfterDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_clampBeforeDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_clampDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_trimAfterDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_trimBeforeDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_trimDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Data_Active_uiDia.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/ui.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Diagrams.Prelude 4 | import Diagrams.Backend.Cairo.CmdLine 5 | 6 | d fun = (square 4 <> ends <> fun # lc red) # lw 0.03 # lineCap LineCapRound # lineJoin LineJoinRound 7 | where ends = vert <> vert # translateX 1 8 | <> rect 1 4 # translateX (0.5) # opacity 0.2 # fc grey 9 | vert = vrule 4 # lw 0.02 # dashing [0.1,0.1] 0 # lc grey 10 | 11 | uiFun = (P (-2,-2) ~~ P (2,2)) 12 | 13 | backwardsFun = (P (2,-1) ~~ P (-1,2)) 14 | 15 | clampFun = fromOffsets [(2,0), (1,1), (1,0)] # centerX 16 | 17 | clampBeforeFun = fromOffsets [(2,0), (2,2)] # centerX 18 | 19 | clampAfterFun = fromOffsets [(3,3), (1,0)] # centerX # translateY (-2) 20 | 21 | trimFun = origin ~~ P (1,1) 22 | 23 | trimBeforeFun = origin ~~ P (2,2) 24 | 25 | trimAfterFun = P (-2,-2) ~~ P(1,1) 26 | 27 | ds = map (pad 1.1 . d) [ uiFun 28 | , clampFun 29 | , clampBeforeFun 30 | , clampAfterFun 31 | , trimFun 32 | , trimBeforeFun 33 | , trimAfterFun 34 | , backwardsFun 35 | ] 36 | 37 | main = multiMain (zip [ "ui" 38 | , "clamp" 39 | , "clampBefore" 40 | , "clampAfter" 41 | , "trim" 42 | , "trimBefore" 43 | , "trimAfter" 44 | , "backwards" 45 | ] 46 | ds 47 | ) -------------------------------------------------------------------------------- /example/Animation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Prelude 7 | import Diagrams.Coordinates 8 | 9 | colors :: Active (Colour Double) 10 | colors = discrete [yellow, blue, red, green, purple] # stretch 3 11 | 12 | anim :: Animation B V2 Double 13 | anim = atop 14 | <$> ( fc 15 | <$> colors 16 | <*> (circle <$> (3 + cut 3 sin')) 17 | ) 18 | <*> pure (square 10 # fc white) 19 | 20 | -- interval' 2 5 :: Active Double 21 | -- circle :: Double -> Diagram 22 | 23 | -- atop :: Diagram -> Diagram -> Diagram 24 | -- square :: Double -> Diagram 25 | -- square 10 # fc white :: Diagram 26 | 27 | anim2 :: Animation B V2 Double 28 | anim2 = atop 29 | <$> (rotateBy <$> (cut 3 sin' / 8) <*> pure (triangle 3)) 30 | <*> pure (square 10 # fc white) 31 | 32 | main = animMain (anim ->> anim2) 33 | 34 | -------------------------------------------------------------------------------- /example/CRT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Color.HSV 7 | import Diagrams.Prelude 8 | 9 | crtGrid :: Int -> Int -> Diagram B 10 | crtGrid m n = mconcat 11 | [ vsep 1 (replicate (m+1) (hrule (fromIntegral n) # alignL # translateX (-0.5))) 12 | # translateY 0.5 13 | , hsep 1 (replicate (n+1) (vrule (fromIntegral m) # alignT # translateY 0.5)) 14 | # translateX (-0.5) 15 | ] 16 | # lineCap LineCapRound 17 | 18 | crt :: Int -> Int -> Animation B V2 Double 19 | crt m n = cut (fromIntegral $ lcm m n) $ 20 | stack 21 | [ pure (crtGrid m n) 22 | , stackAt 23 | [ (fromIntegral k, sqA m n k) | k <- [0 .. lcm m n - 1] ] 24 | , pure (rect (fromIntegral n + 1) (fromIntegral m + 1) # fc white # lw none 25 | # alignTL # translate ((-1) ^& 1)) 26 | ] 27 | 28 | sqA :: Int -> Int -> Int -> Animation B V2 Double 29 | sqA m n k = (fadeIn 0.2 <*> s) ->> s 30 | where 31 | s = pure (sq m n k) 32 | 33 | sq :: Int -> Int -> Int -> Diagram B 34 | sq m n k = mconcat 35 | [ text (show k) # fontSizeL 0.3 36 | , square 1 # fc (c k) # lw none 37 | ] 38 | # moveTo (fromIntegral (k `mod` n) ^& fromIntegral (-(k `mod` m))) 39 | 40 | where 41 | c k = hsvBlend (fromIntegral k / fromIntegral (lcm m n)) lightblue yellow 42 | 43 | -- TODO: animMain should throw an error if given an infinite animation! 44 | main = animMain (crt 3 5) 45 | -------------------------------------------------------------------------------- /example/CRT2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Color.HSV 7 | import Diagrams.Prelude 8 | 9 | crtGrid :: Int -> Int -> Diagram B 10 | crtGrid m n = mconcat 11 | [ vsep 1 (replicate (m+1) (hrule (fromIntegral n) # alignL # translateX (-0.5))) 12 | # translateY 0.5 13 | , hsep 1 (replicate (n+1) (vrule (fromIntegral m) # alignT # translateY 0.5)) 14 | # translateX (-0.5) 15 | ] 16 | # lineCap LineCapRound 17 | 18 | crt :: Int -> Int -> Animation B V2 Double 19 | crt m n = cut (fromIntegral $ lcm m n) $ 20 | stack 21 | [ pure (crtGrid m n) 22 | , stackAt 23 | [ (fromIntegral k, sqA m n k) | k <- [0 .. lcm m n - 1] ] 24 | , pure (rect (fromIntegral n + 1) (fromIntegral m + 1) # fc white # lw none 25 | # alignTL # translate ((-1) ^& 1)) 26 | ] 27 | 28 | sqA :: Int -> Int -> Int -> Animation B V2 Double 29 | sqA m n k = (cut 4 s) ->> s 30 | where 31 | s = pure (sq m n k) 32 | 33 | sq :: Int -> Int -> Int -> Diagram B 34 | sq m n k = mconcat 35 | [ text (show k) # fontSizeL 0.3 36 | , square 1 # fc (c k) # lw none 37 | ] 38 | # moveTo (fromIntegral (k `mod` n) ^& fromIntegral (-(k `mod` m))) 39 | 40 | where 41 | c k = hsvBlend (fromIntegral k / fromIntegral (lcm m n)) lightblue yellow 42 | 43 | -- TODO: animMain should throw an error if given an infinite animation! 44 | main = animMain (crt 3 5) 45 | -------------------------------------------------------------------------------- /example/CRTAccum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Color.HSV 7 | import Diagrams.Prelude 8 | 9 | crtGrid :: Int -> Int -> Diagram B 10 | crtGrid m n = mconcat 11 | [ vsep 1 (replicate (m+1) (hrule (fromIntegral n) # alignL # translateX (-0.5))) 12 | # translateY 0.5 13 | , hsep 1 (replicate (n+1) (vrule (fromIntegral m) # alignT # translateY 0.5)) 14 | # translateX (-0.5) 15 | ] 16 | # lineCap LineCapRound 17 | 18 | crt :: Int -> Int -> Animation B V2 Double 19 | crt m n = cut (fromIntegral $ lcm m n) $ 20 | stack 21 | [ pure (crtGrid m n) 22 | , accumulate (map (sqA m n) [0 .. lcm m n - 1]) 23 | , pure (rect (fromIntegral n + 1) (fromIntegral m + 1) # fc white # lw none 24 | # alignTL # translate ((-1) ^& 1)) 25 | ] 26 | 27 | sqA :: Int -> Int -> Int -> Animation B V2 Double 28 | sqA m n k = cut 1 $ (fadeIn 0.2 <*> s) ->> s 29 | where 30 | s = pure (sq m n k) 31 | 32 | sq :: Int -> Int -> Int -> Diagram B 33 | sq m n k = mconcat 34 | [ text (show k) # fontSizeL 0.3 35 | , square 1 # fc (c k) # lw none 36 | ] 37 | # moveTo (fromIntegral (k `mod` n) ^& fromIntegral (-(k `mod` m))) 38 | 39 | where 40 | c k = hsvBlend (fromIntegral k / fromIntegral (lcm m n)) lightblue yellow 41 | 42 | -- TODO: animMain should throw an error if given an infinite animation! 43 | main = animMain (crt 3 5) 44 | -------------------------------------------------------------------------------- /example/Clock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Prelude 7 | 8 | clock :: Animation B V2 Double 9 | clock = cut 24 $ stack 10 | [ flip rotateBy littleHand <$> -dur' 11 | , flip rotateBy bigHand <$> -dur' / 12 12 | , pure (circle 1 # fc black # lwG 0) 13 | , pure (circle 11 # lwG 1.5 # lc slategray # fc lightsteelblue) 14 | , pure (square 25 # fc white) 15 | ] 16 | where 17 | bigHand = (0 ^& (-1.5)) ~~ (0 ^& 7.5) # lwG 0.5 18 | littleHand = (0 ^& (-2)) ~~ (0 ^& 9.5) # lwG 0.2 19 | 20 | main = animMain clock 21 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | To build the examples: 2 | 3 | - Make sure you have the master branch of `active` checked out and up-to-date. 4 | - `cd example/` 5 | - `stack ghc --package diagrams-lib --package diagrams-rasterific --package diagrams-contrib -- --make Animation.hs && ./Animation -w 300 -h 300 -o Animation.gif` 6 | (or replace `Animation` with whichever example you want to build) 7 | -------------------------------------------------------------------------------- /explore/RandomQ.hs: -------------------------------------------------------------------------------- 1 | import Data.MemoTrie 2 | import Data.Ratio 3 | import Data.Word 4 | import System.Random.TF.Gen 5 | import System.Random.TF.Init 6 | 7 | -- Would it be faster/easier to just run each rational through some 8 | -- hash function? 9 | 10 | rand :: RandomGen g => g -> Word32 11 | rand = fst . next 12 | 13 | left, right, value, subtree :: RandomGen g => g -> g 14 | left = fst . split 15 | right = snd . split 16 | value = left 17 | subtree = right 18 | 19 | -- Given a seed, assign an independent, pseudorandom 32-bit value to 20 | -- every positive rational using the Calkin-Wilf tree and a splittable 21 | -- PRNG from tf-random. 22 | 23 | -- At each node we need to do an extra split: the generator that will 24 | -- make the value for the node on the left, and the generator which 25 | -- will be recursively split to generate the left and right subtrees 26 | -- on the right. 27 | 28 | -- This could probably be improved with a bit of memoization. 29 | 30 | randomQ :: Int -> (Rational -> Word32) 31 | randomQ seed = memo f 32 | where 33 | (g0, g1) = split (mkTFGen seed) 34 | f 0 = rand g0 -- include a special case for 0 which is not in the C-W tree 35 | f r = rand . value $ getGen (numerator r) (denominator r) 36 | -- otherwise find the generator corresponding to r and use it to 37 | -- generate a value 38 | 39 | -- We recurse up the tree to find the path from a/b to 1/1; on the 40 | -- way back down we do appropriate splits (two per step) to find 41 | -- the generator corresponding to a/b. 42 | getGen 1 1 = g1 43 | getGen a b 44 | | a < b = left . subtree $ getGen a (b - a) 45 | | otherwise = right . subtree $ getGen (a - b) b 46 | 47 | -- instance HasTrie a => HasTrie (Ratio a) where 48 | -- newtype (:->:) (Ratio a) b = R ((a,a) :->: b) 49 | -- trie f = R (trie _) 50 | -- untrie (R t) = untrie t . _ 51 | -- enumerate t = _ 52 | 53 | ------------------------------------------------------------ 54 | -- Notes on randomness API 55 | 56 | -- randomGen :: RandomGen g => Active g -- primitive, infinite 57 | -- random, randomRs ... etc., duplicate RandomGen interface in Active? 58 | -- These are obviously just higher-level things built on top of randomGen. 59 | 60 | -- An Active value can be seen as a tree where some of the leaves are 61 | -- instances of randomGen. Each such leaf stores a seed value (Int). 62 | -- By default, all are 0. 63 | 64 | -- Typically if you duplicate an Active that uses randomness the 65 | -- randomness will be fixed, so the two will be identical. But if you 66 | -- want to duplicate something but use different randomness, you can 67 | -- wrap it in: 68 | 69 | -- randomize :: Active a -> Active a 70 | 71 | -- Picks new globally unique seeds for all randomGen primitives 72 | -- contained in it. But note if any of them already have the same 73 | -- seed they should still share the same (new) seed! 74 | 75 | -- What if you want to set your own seed explicitly? Maybe you want 76 | -- to try different seeds and find one that looks good, and then be 77 | -- sure that you will always and forever have that particular fixed 78 | -- seed. For example iterating 'randomize' a fixed number of times is 79 | -- no good, because randomize might be called elsewhere, and which 80 | -- seed you get depends on the order in which the calls to randomize 81 | -- are evaluated, which is unpredictable. 82 | 83 | -- Maybe something like 84 | 85 | -- withSeed :: Int -> Active a -> Active a 86 | 87 | -- What should its semantics be?? 88 | -- 89 | -- Alternatively we could duplicate the entire API and make versions 90 | -- that take a seed as an extra parameter. 91 | 92 | -- Note we need a global gensym for automatically chosen seeds 93 | -- (i.e. unsafe IORef etc.) but we also need to make sure that 94 | -- user-chosen seeds are disjoint from generated seeds. Perhaps for 95 | -- each Int seed value we can generate the TFGen for that seed and 96 | -- then split once, to give the root generators for system-generated 97 | -- or user-chosen seed values. 98 | 99 | -- Do we need to worry about what happens when you do parallel 100 | -- composition of things that use randomness? 101 | -------------------------------------------------------------------------------- /explore/Sticky.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | 6 | import Data.Char 7 | import Data.Monoid (Sum (..)) 8 | 9 | -- | Lists can be sticky or dry (non-sticky). This type is isomorphic 10 | -- to Bool, except that in the case of sticky lists it carries along 11 | -- an appropriate Semigroup instance to carry out the necessary 12 | -- sticking; that is, pattern-matching on the Sticky constructor 13 | -- will bring a Semigroup instance into scope. It is also indexed 14 | -- by Bool to be able to link it appropriately to actual lists. 15 | data Stickiness :: Bool -> * -> * where 16 | Sticky :: Semigroup a => Stickiness True a 17 | Dry :: Stickiness False a 18 | 19 | -- | A (possibly) sticky list carries Stickiness evidence and a list of 20 | -- values. 21 | data StickyList :: Bool -> * -> * where 22 | SL :: Stickiness s a -> [a] -> StickyList s a 23 | 24 | -- | Extract the list content of a StickyList. 25 | getList :: StickyList s a -> [a] 26 | getList (SL _ as) = as 27 | 28 | -- | The empty StickyList (identity element for ). 29 | emptySticky :: StickyList False a 30 | emptySticky = SL Dry [] 31 | 32 | -- | We can map over a sticky list, but we need to know whether the 33 | -- result should be sticky (and provide a suitable Semigroup 34 | -- instance for b if it should be). Note for technical reasons (see 35 | -- the comment at 'mapGlue') it's convenient to simply discard the 36 | -- stickiness of the input list, even though one might expect it to 37 | -- have the same stickiness as the output. 38 | mapStickyList :: Stickiness s b -> (a -> b) -> StickyList t a -> StickyList s b 39 | mapStickyList Dry f (SL _ as) = SL Dry (map f as) 40 | mapStickyList Sticky f (SL _ bs) = SL Sticky (map f bs) 41 | 42 | -- | Note we can't actually make 'StickyList' a 'Monoid' instance 43 | -- because we want to combine sticky and non-sticky lists, which 44 | -- have different types. Fortunately we don't actually need a 45 | -- 'Monoid' instance, we can just use this operator. 46 | -- 47 | -- Notice how in the SL Sticky xs case, pattern-matching on Sticky 48 | -- brings a Semigroup a instance into scope, which is needed to call 49 | -- (++<>). 50 | () :: StickyList s a -> StickyList t a -> StickyList t a 51 | SL _ [] ys = ys 52 | SL Dry xs SL s ys = SL s (xs ++ ys) -- normal append for dry list + list 53 | SL Sticky xs SL s ys = SL s (xs ++<> ys) -- sticky append for sticky list + list 54 | 55 | -- | Sticky append. Like normal append, but combines the last element 56 | -- of the first list with the first element of the second. 57 | (++<>) :: Semigroup a => [a] -> [a] -> [a] 58 | [] ++<> ys = ys 59 | [x] ++<> (y:ys) = (x <> y) : ys 60 | (x:xs) ++<> ys = x : (xs ++<> ys) 61 | 62 | -- | The Cayley representation for StickyList, i.e. the usual trick 63 | -- for optimizing nested appends by turning them into function 64 | -- composition which naturally reassociates all the append 65 | -- operations to the right. Note it takes Dry things, not Sticky: 66 | -- the function should be thought of as taking the remainder of a 67 | -- list and appending it to some initial prefix, and the very end of 68 | -- the ultimately produced list will never be sticky. 69 | newtype Glue a = G { runG :: StickyList False a -> StickyList False a } 70 | 71 | -- | Create a Glue value directly from a list, given the desired stickiness. 72 | mkGlue :: Stickiness s a -> [a] -> Glue a 73 | mkGlue s = G . () . SL s 74 | 75 | -- | Extract a list from a Glue value. 76 | runGlue :: Glue a -> [a] 77 | runGlue = getList . ($ emptySticky) . runG 78 | 79 | -- | To map a function over a Glue value, we again need to know the 80 | -- desired stickiness of the result (along with a Semigroup instance 81 | -- as appropriate). Notice that Glue itself is not a Functor, 82 | -- because the type parameter occurs both positively and negatively. 83 | -- To implement 'mapGlue', we convert to a normal Sticky list by 84 | -- applying to the empty list, then calling 'mapStickyList', then 85 | -- converting back to a 'Glue' value. This incurs the linear cost 86 | -- of actually constructing the entire list --- but a call to map 87 | -- would incur a cost proportional to this anyway. 88 | -- 89 | -- Notice that the function embedded in the Glue a value will always 90 | -- result in a non-sticky list, regardless of what the ultimate 91 | -- stickiness of the result is supposed to be. This is why we need 92 | -- mapStickyList to ignore the stickiness of the input list, 93 | -- i.e. not require it to be the same as the output stickiness. 94 | mapGlue :: Stickiness s b -> (a -> b) -> Glue a -> Glue b 95 | mapGlue s f = G . () . mapStickyList s f . ($ emptySticky) . runG 96 | 97 | apGlue :: Stickiness s b -> Glue (a -> b) -> Glue a -> Glue b 98 | apGlue s f x = mkGlue s $ zipWith ($) (runGlue f) (runGlue x) 99 | 100 | -- | Glue values form a semigroup under function composition. 101 | instance Semigroup (Glue a) where 102 | G s1 <> G s2 = G (s1 . s2) 103 | 104 | instance Monoid (Glue a) where 105 | mempty = G id 106 | mappend = (<>) 107 | 108 | {- 109 | 110 | Using Glue to compute a left-nested composition is fast: 111 | 112 | >>> length . runGlue $ foldl (<>) mempty (map (mkGlue Sticky) (replicate 1000 (map Sum [1..100]))) 113 | 99001 114 | 115 | -} 116 | 117 | -- We can use Glue to interpret a nested AST, even one encoded by a 118 | -- GADT with embedded Fmap (and hence existentially quantified type 119 | -- variables) and embedded Semigroup constraints. 120 | 121 | data Expr a where 122 | Prim :: [a] -> Expr a 123 | Fmap :: (a -> b) -> Expr a -> Expr b 124 | App :: Expr a -> Expr a -> Expr a 125 | Glue :: Semigroup a => Expr a -> Expr a -> Expr a 126 | -- Instead of separate App and Glue constructors, we could just as 127 | -- well have a single constructor with an additional (Stickiness s 128 | -- a) field. 129 | 130 | Ap :: Expr (a -> b) -> Expr a -> Expr b 131 | 132 | interp :: Expr a -> [a] 133 | interp = runGlue . go Dry 134 | where 135 | go :: Stickiness s a -> Expr a -> Glue a 136 | go s (Prim xs) = mkGlue s xs 137 | go s (Fmap f e) = mapGlue s f (go Dry e) 138 | go s (App e1 e2) = go Dry e1 <> go s e2 139 | go s (Glue e1 e2) = go Sticky e1 <> go s e2 140 | go s (Ap f x) = apGlue s (go Dry f) (go Dry x) 141 | 142 | example :: [Int] 143 | example = map getSum . interp $ e 144 | where 145 | e = App (Fmap Sum (Prim [1,2,3])) 146 | (Glue 147 | (Glue (Prim [Sum 5, Sum 7]) 148 | (Fmap (Sum . ord) (Prim "brent"))) 149 | (Fmap Sum (Prim [10, 22, 35]))) 150 | 151 | -- >>> example 152 | -- [1, 2, 3, 5, 105, 114, 101, 110, 126, 22, 35] 153 | 154 | -------------------------------------------------------------------------------- /old-semantics/ActiveDiagrams.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module ActiveDiagrams where 10 | 11 | import Diagrams.Backend.Cairo 12 | import Diagrams.Coordinates 13 | import Diagrams.Prelude hiding (Active) 14 | import Graphics.SVGFonts.ReadFont 15 | 16 | timeline :: Double -> Double -> Diagram Cairo R2 17 | timeline t1 t2 = 18 | circle 0.2 # fc black 19 | <> (t1 & 0) ~~ (t2 & 0) # dashing [0.1,0.1] 0 20 | <> arrowhead # moveTo (t2 & 0) 21 | <> arrowhead # reflectX # moveTo (t1 & 0) 22 | where 23 | arrowhead = fromOffsets [(1&(-1)), ((-1)&(-1))] 24 | # scale 0.3 25 | # scaleY 0.5 26 | # lineCap LineCapRound 27 | # centerY 28 | # alignR 29 | 30 | data End = I 31 | | C Double 32 | | O Double 33 | 34 | newtype Active = Active (End, Diagram Cairo R2, End) 35 | 36 | class Drawable d where 37 | draw :: d -> Diagram Cairo R2 38 | 39 | instance Drawable Active where 40 | draw (Active (s, d, e)) = drawLine s <> drawLine e <> d 41 | where 42 | drawLine I = mempty 43 | drawLine (C x) = vrule 3 # lw 0.1 # translateX x 44 | drawLine (O x) = vrule 3 # lw 0.1 # dashing [0.2,0.2] 0 # lc grey # translateX x -- XXX fix me 45 | 46 | active' :: Double -> Double -> Diagram Cairo R2 -> Active 47 | active' s e d = Active 48 | ( C s 49 | , d 50 | , C e 51 | ) 52 | 53 | active :: Double -> Double -> Colour Double -> Active 54 | active s e c = active' s e (activeRect s e c) 55 | 56 | activeRect :: Double -> Double -> Colour Double -> Diagram Cairo R2 57 | activeRect s e c 58 | = rect (e - s) 2 # lw 0 # fcA (c `withOpacity` 0.5) # alignL # translateX s 59 | 60 | activeD :: Double -> Double -> Colour Double -> Diagram Cairo R2 61 | activeD s e c = draw (active s e c) 62 | 63 | activeD' :: (Double -> End) -> (Double -> End) -> Double -> Double -> [Colour Double] -> Diagram Cairo R2 64 | activeD' l r s e cs = draw $ Active (l s, mconcat . map (activeRect s e) $ cs, r e) 65 | 66 | activeDR :: Double -> Double -> Colour Double -> Diagram Cairo R2 67 | activeDR s e c = activeD' C O s e [c] 68 | 69 | a1, a2, a12 :: Diagram Cairo R2 70 | a1 = activeD (-6) 3 red 71 | a2 = activeD (-1) 5 blue 72 | a12 = draw (active' (-1) 3 (activeRect (-1) 3 red <> activeRect (-1) 3 blue)) 73 | 74 | a1R :: Diagram Cairo R2 75 | a1R = draw $ Active (C (-6), a1RRect, I) 76 | where 77 | a1RRect = activeRect (-6) 3 red 78 | ||| fade 7 0.5 0 50 79 | 80 | -- Hack since diagrams doesn't yet support gradients. This doesn't even look right. 81 | fade len o1 o2 n = 82 | hcat (map (\o -> let c = red `withOpacity` o in rect (len / n) 2 # lw 0 # fcA c) 83 | [o1, o1 + (o2 - o1) / (n - 1) .. o2] 84 | ) 85 | 86 | tl :: Diagram Cairo R2 87 | tl = timeline (-10) 10 88 | 89 | text' :: Renderable (Path R2) b => String -> Diagram b R2 90 | text' s = (stroke $ textSVG' (TextOpts s lin2 INSIDE_H KERN False 4 4)) # fc black # lw 0 91 | 92 | seqR = triangle 1 # rotateBy (-1/4) # lw 0.15 93 | -------------------------------------------------------------------------------- /old-semantics/FARM/A.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/old-semantics/FARM/A.png -------------------------------------------------------------------------------- /old-semantics/FARM/ActiveDiagrams.hs: -------------------------------------------------------------------------------- 1 | ../ActiveDiagrams.hs -------------------------------------------------------------------------------- /old-semantics/FARM/C.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/old-semantics/FARM/C.png -------------------------------------------------------------------------------- /old-semantics/FARM/D.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/old-semantics/FARM/D.png -------------------------------------------------------------------------------- /old-semantics/FARM/Shake.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.FilePath 3 | 4 | lhs2TeX = "lhs2TeX" 5 | pdflatex = "pdflatex" 6 | bibtex = "bibtex" 7 | 8 | main :: IO () 9 | main = shake shakeOptions $ do 10 | want ["abstract.pdf"] 11 | 12 | "*.tex" *> \output -> do 13 | let input = replaceExtension output "lhs" 14 | need [input] 15 | system' lhs2TeX $ ["-o", output] ++ [input] 16 | 17 | "*.pdf" *> \output -> do 18 | let input = replaceExtension output "tex" 19 | need [input] 20 | system' pdflatex $ ["--enable-write18", input] 21 | 22 | need [replaceExtension input "bib"] 23 | system' bibtex $ [dropExtension input] 24 | system' pdflatex $ ["--enable-write18", input] 25 | -------------------------------------------------------------------------------- /old-semantics/FARM/abstract.bib: -------------------------------------------------------------------------------- 1 | @incollection{matlage2011every, 2 | title={Every Animation Should Have a Beginning, a Middle, and an End}, 3 | author={Matlage, Kevin and Gill, Andy}, 4 | booktitle={Trends in Functional Programming}, 5 | pages={150--165}, 6 | year={2011}, 7 | publisher={Springer} 8 | } 9 | 10 | @incollection{hudak2004algebraic, 11 | title={An algebraic theory of polymorphic temporal media}, 12 | author={Hudak, Paul}, 13 | booktitle={Practical Aspects of Declarative Languages}, 14 | pages={1--15}, 15 | year={2004}, 16 | publisher={Springer} 17 | } 18 | 19 | @inproceedings{elliott1997functional, 20 | title={Functional reactive animation}, 21 | author={Elliott, Conal and Hudak, Paul}, 22 | booktitle={ACM SIGPLAN Notices}, 23 | volume={32}, 24 | number={8}, 25 | pages={263--273}, 26 | year={1997}, 27 | organization={ACM} 28 | } 29 | 30 | @InCollection{Elliott03:FOP, 31 | author = {Conal Elliott}, 32 | title = {Functional Images}, 33 | url = {http://conal.net/papers/functional-images/}, 34 | booktitle = {The Fun of Programming}, 35 | publisher = {Palgrave}, 36 | year = 2003, 37 | series = {``Cornerstones of Computing'' series}, 38 | month = mar 39 | } 40 | 41 | @misc{yorgey2011active, 42 | title={The \texttt{active} package, version 0.1}, 43 | author={Yorgey, Brent}, 44 | url={http://hackage.haskell.org/package/active-0.1.0.4}, 45 | year={2011} 46 | } 47 | 48 | @InProceedings {Elliott2009:push-pull-frp, 49 | author = {Conal Elliott}, 50 | title = {Push-pull functional reactive programming}, 51 | booktitle = {Haskell Symposium}, 52 | url = {http://conal.net/papers/push-pull-frp}, 53 | year = 2009 54 | } 55 | -------------------------------------------------------------------------------- /old-semantics/FARM/diagrams-latex.sty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/old-semantics/FARM/diagrams-latex.sty -------------------------------------------------------------------------------- /old-semantics/IApplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE ConstraintKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | 13 | import Prelude hiding (cycle, repeat, pure) 14 | import qualified Prelude as P 15 | import GHC.Exts (Constraint) 16 | 17 | class IFunctor (f :: k -> * -> *) where 18 | imap :: (a -> b) -> f i a -> f i b 19 | 20 | class IFunctor f => IApplicative (f :: k -> * -> *) where 21 | type I :: k 22 | type (:*:) (a :: k) (b :: k) :: k 23 | ipure :: a -> f I a 24 | (<:*>) :: f i (a -> b) -> f j a -> f (i :*: j) b 25 | 26 | data Finitude = Fin | Inf 27 | 28 | type family Isect (f1 :: Finitude) (f2 :: Finitude) :: Finitude where 29 | Isect Fin f = Fin 30 | Isect f Fin = Fin 31 | Isect f g = Inf 32 | 33 | newtype FList (f :: Finitude) (a :: *) = FList [a] 34 | deriving Show 35 | 36 | instance IFunctor FList where 37 | imap f (FList xs) = FList (map f xs) 38 | 39 | cycle :: [a] -> FList Inf a 40 | cycle = FList . P.cycle 41 | 42 | repeat :: a -> FList Inf a 43 | repeat = FList . P.repeat 44 | 45 | fin :: [a] -> FList Fin a 46 | fin as = length as `seq` (FList as) 47 | 48 | instance IApplicative FList where 49 | type I = Inf 50 | type (:*:) i j = Isect i j 51 | ipure = repeat 52 | (FList fs) <:*> (FList xs) = FList (zipWith ($) fs xs) 53 | 54 | data N = Z | S N | NInf 55 | 56 | type family Succ (n :: N) :: N where 57 | Succ NInf = NInf 58 | Succ n = S n 59 | 60 | type family Min (m :: N) (n :: N) :: N where 61 | Min NInf n = n 62 | Min m NInf = m 63 | Min Z n = Z 64 | Min m Z = Z 65 | Min (S m) (S n) = S (Min m n) 66 | 67 | data Vec :: N -> * -> * where 68 | VNil :: Vec Z a 69 | VCons :: a -> Vec n a -> Vec (S n) a 70 | VInf :: a -> Vec NInf a -> Vec NInf a 71 | 72 | deriving instance Show a => Show (Vec n a) 73 | 74 | vrepeat :: a -> Vec NInf a 75 | vrepeat a = VInf a (vrepeat a) 76 | 77 | vcycle :: [a] -> Vec NInf a 78 | vcycle as = vcycle' as as 79 | where 80 | vcycle' [] as' = vcycle' as' as' 81 | vcycle' (a:as) as' = VInf a (vcycle' as as') 82 | 83 | instance IFunctor Vec where 84 | imap _ VNil = VNil 85 | imap f (VCons a as) = VCons (f a) (imap f as) 86 | imap f (VInf a as) = VInf (f a) (imap f as) 87 | 88 | instance IApplicative Vec where 89 | type I = NInf 90 | type (:*:) m n = Min m n 91 | ipure a = VInf a (ipure a) 92 | VInf f fs <:*> VInf x xs = VInf (f x) (fs <:*> xs) 93 | VInf f fs <:*> VCons x xs = VCons (f x) (fs <:*> xs) 94 | VCons f fs <:*> VInf x xs = VCons (f x) (fs <:*> xs) 95 | VNil <:*> _ = VNil 96 | _ <:*> VNil = VNil 97 | VCons f fs <:*> VCons x xs = VCons (f x) (fs <:*> xs) 98 | 99 | ------------------------------------------------------------ 100 | 101 | newtype List (i :: *) a = List [a] 102 | deriving Show 103 | 104 | instance IFunctor List where 105 | imap f (List as) = List (fmap f as) 106 | 107 | instance IApplicative List where 108 | type I = () 109 | type (:*:) i j = () 110 | ipure = List . pure 111 | List fs <:*> List xs = List (fs <*> xs) 112 | 113 | ------------------------------------------------------------ 114 | -- Generalizing... 115 | 116 | newtype Ix f (i :: *) (a :: *) = Ix (f a) 117 | deriving Show 118 | 119 | instance Functor f => IFunctor (Ix f) where 120 | imap f (Ix x) = Ix (fmap f x) 121 | 122 | instance Applicative f => IApplicative (Ix f) where 123 | type I = () 124 | type (:*:) i j = () 125 | ipure = Ix . P.pure 126 | Ix f <:*> Ix x = Ix (f <*> x) 127 | 128 | ---------------------------------------------------------------------- 129 | -- Now, can we define pure and <*> so they work on indexed OR 130 | -- non-indexed things? With clever use of type families, perhaps? 131 | -- 132 | -- Hmmm... really not sure whether this is possible. 133 | ---------------------------------------------------------------------- 134 | 135 | -- this works... 136 | type family AppClass (f :: k) :: k -> Constraint 137 | type instance AppClass (f :: * -> *) = Applicative 138 | type instance AppClass (f :: i -> * -> *) = IApplicative 139 | 140 | -- ...but not sure how to make this work. 141 | pure :: forall (f :: k -> *) (a :: *). AppClass f f => a -> f a 142 | pure = undefined 143 | -------------------------------------------------------------------------------- /old-semantics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Brent Yorgey 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Brent Yorgey nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /old-semantics/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /old-semantics/Shake.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.FilePath 3 | 4 | lhs2TeX = "lhs2TeX" 5 | pdflatex = "pdflatex" 6 | bibtex = "bibtex" 7 | 8 | main :: IO () 9 | main = shake shakeOptions $ do 10 | want ["active-semantics.pdf"] 11 | 12 | "*.tex" *> \output -> do 13 | let input = replaceExtension output "lhs" 14 | need [input] 15 | system' lhs2TeX $ ["-o", output] ++ [input] 16 | 17 | "*.pdf" *> \output -> do 18 | let input = replaceExtension output "tex" 19 | need [input] 20 | system' pdflatex $ ["--enable-write18", input] 21 | system' bibtex $ [dropExtension input] 22 | system' pdflatex $ ["--enable-write18", input] 23 | -------------------------------------------------------------------------------- /old-semantics/active-semantics.bib: -------------------------------------------------------------------------------- 1 | @incollection{matlage2011every, 2 | title={Every Animation Should Have a Beginning, a Middle, and an End}, 3 | author={Matlage, Kevin and Gill, Andy}, 4 | booktitle={Trends in Functional Programming}, 5 | pages={150--165}, 6 | year={2011}, 7 | publisher={Springer} 8 | } 9 | 10 | @incollection{hudak2004algebraic, 11 | title={An algebraic theory of polymorphic temporal media}, 12 | author={Hudak, Paul}, 13 | booktitle={Practical Aspects of Declarative Languages}, 14 | pages={1--15}, 15 | year={2004}, 16 | publisher={Springer} 17 | } 18 | 19 | @misc{yorgey2011active, 20 | title={The \texttt{active} package, version 0.1}, 21 | author={Yorgey, Brent}, 22 | url={http://hackage.haskell.org/package/active-0.1.0.4}, 23 | year={2011} 24 | } -------------------------------------------------------------------------------- /old-semantics/active-semantics.cabal: -------------------------------------------------------------------------------- 1 | -- Initial active-semantics.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: active-semantics 5 | version: 0 6 | synopsis: Dummy package just to make ghc-mod happy 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Brent Yorgey 11 | maintainer: byorgey@cis.upenn.edu 12 | -- copyright: 13 | category: Graphics 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | 17 | library 18 | exposed-modules: Shake, ActiveDiagrams 19 | -- other-modules: 20 | build-depends: base ==4.6.*, shake ==0.10.*, diagrams-cairo ==0.6.*, diagrams-lib ==0.6.*, SVGFonts -------------------------------------------------------------------------------- /old-semantics/old/ActiveDiagrams.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module ActiveDiagrams where 10 | 11 | import Diagrams.Backend.Cairo 12 | import Diagrams.Coordinates 13 | import Diagrams.Prelude hiding (Active) 14 | import Graphics.SVGFonts.ReadFont 15 | 16 | timeline :: Double -> Double -> Diagram Cairo R2 17 | timeline t1 t2 = 18 | circle 0.2 # fc black 19 | <> (t1 & 0) ~~ (t2 & 0) # dashing [0.1,0.1] 0 20 | <> arrowhead # moveTo (t2 & 0) 21 | <> arrowhead # reflectX # moveTo (t1 & 0) 22 | where 23 | arrowhead = fromOffsets [(1&(-1)), ((-1)&(-1))] 24 | # scale 0.3 25 | # scaleY 0.5 26 | # lineCap LineCapRound 27 | # centerY 28 | # alignR 29 | 30 | data End = I 31 | | C Double 32 | | O Double 33 | 34 | newtype Active = Active (End, Diagram Cairo R2, End) 35 | 36 | class Drawable d where 37 | draw :: d -> Diagram Cairo R2 38 | 39 | instance Drawable Active where 40 | draw (Active (s, d, e)) = drawLine s <> drawLine e <> d 41 | where 42 | drawLine I = mempty 43 | drawLine (C x) = vrule 3 # lw 0.1 # translateX x 44 | drawLine (O x) = vrule 3 # lw 0.1 # dashing [0.2,0.2] 0 # lc grey # translateX x -- XXX fix me 45 | 46 | active' :: Double -> Double -> Diagram Cairo R2 -> Active 47 | active' s e d = Active 48 | ( C s 49 | , d 50 | , C e 51 | ) 52 | 53 | active :: Double -> Double -> Colour Double -> Active 54 | active s e c = active' s e (activeRect s e c) 55 | 56 | activeRect :: Double -> Double -> Colour Double -> Diagram Cairo R2 57 | activeRect s e c 58 | = rect (e - s) 2 # lw 0 # fcA (c `withOpacity` 0.5) # alignL # translateX s 59 | 60 | activeD :: Double -> Double -> Colour Double -> Diagram Cairo R2 61 | activeD s e c = draw (active s e c) 62 | 63 | activeD' :: (Double -> End) -> (Double -> End) -> Double -> Double -> [Colour Double] -> Diagram Cairo R2 64 | activeD' l r s e cs = draw $ Active (l s, mconcat . map (activeRect s e) $ cs, r e) 65 | 66 | activeDR :: Double -> Double -> Colour Double -> Diagram Cairo R2 67 | activeDR s e c = activeD' C O s e [c] 68 | 69 | a1, a2, a12 :: Diagram Cairo R2 70 | a1 = activeD (-6) 3 red 71 | a2 = activeD (-1) 5 blue 72 | a12 = draw (active' (-1) 3 (activeRect (-1) 3 red <> activeRect (-1) 3 blue)) 73 | 74 | a1R :: Diagram Cairo R2 75 | a1R = draw $ Active (C (-6), a1RRect, I) 76 | where 77 | a1RRect = activeRect (-6) 3 red 78 | ||| fade 7 0.5 0 50 79 | 80 | -- Hack since diagrams doesn't yet support gradients. This doesn't even look right. 81 | fade len o1 o2 n = 82 | hcat (map (\o -> let c = red `withOpacity` o in rect (len / n) 2 # lw 0 # fcA c) 83 | [o1, o1 + (o2 - o1) / (n - 1) .. o2] 84 | ) 85 | 86 | tl :: Diagram Cairo R2 87 | tl = timeline (-10) 10 88 | 89 | text' :: Renderable (Path R2) b => String -> Diagram b R2 90 | text' s = (stroke $ textSVG' (TextOpts s lin2 INSIDE_H KERN False 4 4)) # fc black # lw 0 91 | 92 | seqR = triangle 1 # rotateBy (-1/4) # lw 0.15 93 | -------------------------------------------------------------------------------- /old-semantics/old/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Brent Yorgey 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Brent Yorgey nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /old-semantics/old/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /old-semantics/old/Shake.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.FilePath 3 | 4 | lhs2TeX = "lhs2TeX" 5 | pdflatex = "pdflatex" 6 | bibtex = "bibtex" 7 | 8 | main :: IO () 9 | main = shake shakeOptions $ do 10 | want ["active-semantics.pdf"] 11 | 12 | "*.tex" *> \output -> do 13 | let input = replaceExtension output "lhs" 14 | need [input] 15 | system' lhs2TeX $ ["-o", output] ++ [input] 16 | 17 | "*.pdf" *> \output -> do 18 | let input = replaceExtension output "tex" 19 | need [input] 20 | system' pdflatex $ ["--enable-write18", input] 21 | system' bibtex $ [dropExtension input] 22 | system' pdflatex $ ["--enable-write18", input] 23 | -------------------------------------------------------------------------------- /old-semantics/old/active-semantics.bib: -------------------------------------------------------------------------------- 1 | @incollection{matlage2011every, 2 | title={Every Animation Should Have a Beginning, a Middle, and an End}, 3 | author={Matlage, Kevin and Gill, Andy}, 4 | booktitle={Trends in Functional Programming}, 5 | pages={150--165}, 6 | year={2011}, 7 | publisher={Springer} 8 | } 9 | 10 | @incollection{hudak2004algebraic, 11 | title={An algebraic theory of polymorphic temporal media}, 12 | author={Hudak, Paul}, 13 | booktitle={Practical Aspects of Declarative Languages}, 14 | pages={1--15}, 15 | year={2004}, 16 | publisher={Springer} 17 | } 18 | 19 | @misc{yorgey2011active, 20 | title={The \texttt{active} package, version 0.1}, 21 | author={Yorgey, Brent}, 22 | url={http://hackage.haskell.org/package/active-0.1.0.4}, 23 | year={2011} 24 | } -------------------------------------------------------------------------------- /old-semantics/old/active-semantics.cabal: -------------------------------------------------------------------------------- 1 | -- Initial active-semantics.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: active-semantics 5 | version: 0 6 | synopsis: Dummy package just to make ghc-mod happy 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Brent Yorgey 11 | maintainer: byorgey@cis.upenn.edu 12 | -- copyright: 13 | category: Graphics 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | 17 | library 18 | exposed-modules: Shake, ActiveDiagrams 19 | -- other-modules: 20 | build-depends: base ==4.6.*, shake ==0.10.*, diagrams-cairo ==0.6.*, diagrams-lib ==0.6.*, SVGFonts -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig1.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | dia = a1 <> tl 3 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig10.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = vcat' with {sep = 1} 4 | [ activeDR (-3) 1 red <> tl 5 | , seqR 6 | , activeDR (-4) 3 blue <> tl 7 | , text' "=" 8 | , vcat 9 | [ mconcat 10 | [ ( ((-4) & 0) ~~ (0.5 & 0) ) # dashing [0.2,0.2] 0 11 | , triangle 0.5 # rotateBy (-1/4) # alignR # translateX 1 # lw 0 12 | ] 13 | # lw 0.2 # lc blue # fc blue # opacity 0.5 14 | , result 15 | ] 16 | ] 17 | 18 | result = (draw $ Active (C (-3), r, O 8)) <> tl -- $ 19 | where 20 | r = hcat [ activeRect (-3) 1 red, activeRect 1 8 blue ] 21 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig11.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = vcat' with {sep = 1} 4 | [ a1 <> tl 5 | , text' "~" 6 | , a1 # translateX 4 <> tl 7 | ] 8 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig12.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | dia = (a1 # centerXY) <> phantom tl 3 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig13.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | b1 = activeD' C C (-6) 3 [red] 4 | b2 = activeD' O C (-1) 5 [blue] 5 | b12 = activeD' O C (-1) 3 [red,blue] 6 | 7 | bs :: Diagram Cairo R2 8 | bs = cat' unitY with {sep = 0.5} [b12, b2, b1] 9 | 10 | b1' = activeD' C C (-6) 3 [red] 11 | b2' = activeD' O C (-8) 5 [blue] 12 | b12' = activeD' C C (-6) 3 [red,blue] 13 | 14 | bs' = cat' unitY with {sep = 0.5} [b12', b2', b1'] 15 | 16 | dia = hcat [ bs <> tl , strutX 3, bs' <> tl ] 17 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig2.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | as :: Diagram Cairo R2 3 | as = cat' unitY with {sep = 0.5} 4 | [ draw (active' (-6) 3 (activeRect (-6) 3 red <> activeRect (-6) 3 blue)) 5 | , activeD (-6) 3 blue 6 | , activeD (-6) 3 red 7 | ] 8 | 9 | dia = as <> tl 10 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig3.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | as :: Diagram Cairo R2 3 | as = cat' unitY with {sep = 0.5} [a12, a2, a1] 4 | dia = ( vrule (height as) # translateX (-1) 5 | <> vrule (height as) # translateX 3 6 | ) 7 | # alignB # translateY (-1.5) 8 | # lw 0.1 # dashing [0.3,0.2] 0 9 | <> as 10 | <> tl 11 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig4.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | dia = a1R <> tl 3 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig5.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | dia = (cat' unitY with [a1X,a2X]) <> tl 3 | 4 | a2X = mconcat 5 | [ a2 6 | , text' "?" # scale 0.7 # translateX (-3.5) 7 | , activeRect (-6) (-1) (blend 0.7 blue white) 8 | ] 9 | 10 | a1X = mconcat 11 | [ a1 12 | , text' "?" # scale 0.7 # translateX 4 13 | , activeRect 3 5 (blend 0.5 red white) 14 | ] 15 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig6.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = vcat' with {sep = 1} 4 | [ hcat' with {sep = 2} 5 | [ activeD (-3) 1 red 6 | , seqR 7 | , activeD (-4) 3 blue 8 | ] # centerX 9 | , text' "=" 10 | , result # centerX <> phantom tl 11 | ] 12 | 13 | result = (draw $ active' (-3) 8 (activeRect (-3) 1 red ||| activeRect 1 8 blue)) 14 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig7.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = result # centerX <> phantom tl 4 | 5 | result = atop (text' "?" # scale 0.7 # translateX 1). draw . active' (-3) 8 $ hcat 6 | [ activeRect (-3) 1 red 7 | , vrule 3 # lw 0.1 # dashing [0.1,0.1] 0 # lc grey 8 | , activeRect 1 8 blue 9 | ] 10 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig8.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = oc <> tl 4 | 5 | oc = draw $ Active (O (-6), r, C 3) -- $ 6 | where 7 | r = activeRect (-6) 3 red 8 | -------------------------------------------------------------------------------- /old-semantics/old/diagrams/active-semantics-diagrams-latex-fig9.hs: -------------------------------------------------------------------------------- 1 | import ActiveDiagrams 2 | 3 | dia = infO <> tl 4 | 5 | infO = draw $ Active (I, r, O 2) -- $ 6 | where 7 | r = cat' unit_X with 8 | [ activeRect (-2) 2 red 9 | , fade 7 0 0.5 50 10 | ] 11 | -------------------------------------------------------------------------------- /paper/haskell2020/Shake.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.FilePath 3 | 4 | lhs2TeX, pdflatex, bibtex :: String 5 | lhs2TeX = "lhs2TeX" 6 | pdflatex = "pdflatex" 7 | bibtex = "bibtex" 8 | 9 | main :: IO () 10 | main = shake shakeOptions $ do 11 | 12 | want ["active.pdf"] 13 | 14 | "*.tex" %> \output -> do 15 | let input = replaceExtension output "lhs" 16 | need [input] 17 | cmd lhs2TeX $ ["-o", output] ++ [input] 18 | 19 | "*.bbl" %> \output -> do 20 | let input = output -<.> "bib" 21 | need [input] 22 | cmd bibtex [dropExtension input] 23 | 24 | "*.pdf" %> \output -> do 25 | let input = replaceExtension output "tex" 26 | need [input] 27 | 28 | () <- cmd pdflatex $ ["--enable-write18", input] 29 | cmd pdflatex $ ["--enable-write18", input] 30 | -------------------------------------------------------------------------------- /paper/haskell2020/acmart.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/paper/haskell2020/acmart.pdf -------------------------------------------------------------------------------- /paper/haskell2020/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | stack build diagrams diagrams-pgf diagrams-builder palette shake &&\ 4 | stack runghc --package shake --package diagrams-builder Shake.hs 5 | -------------------------------------------------------------------------------- /paper/haskell2020/diagrams-latex.sty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/active/a9a6dd504e40e1789f7c091c9c2f6c3d177adecd/paper/haskell2020/diagrams-latex.sty -------------------------------------------------------------------------------- /paper/haskell2020/notes.txt: -------------------------------------------------------------------------------- 1 | # Rough draft 2 | 3 | Motivation: 4 | 5 | What is the problem space? 6 | What is the algebraic structure through examples. 7 | 8 | This is not real-time interactive rendering. These animations take time to 9 | render, and it's not the focus. 10 | 11 | We don't want to do mapping on time. 12 | 13 | horizontal composition, sequencing, and overlap on endpoints with an arbitrary 14 | semigroup. 15 | two kinds of parallel composition. neither is more fundamental. 16 | 17 | 18 | One is the applicative instance, which motivates why we want to do infinite 19 | things. 20 | 21 | Pure creates infinite things. Clock example is a good practical motivation. 22 | 23 | This is good but we have terrible quadratic performance. 24 | Now we switch to using a deep embedding. 25 | How to do linear time sampling using affine rays. 26 | The glue monoid. 27 | 28 | QR code idea ought to go in. 29 | 30 | 31 | ## NOT in the paper: 32 | * Monoidal annotations. Pause points, page numbers, named anchor points. 33 | The story isn't quite finished here, becuase there needs to be something 34 | affine. A semiring and an action? There's a story there, but that's another 35 | paper. 36 | 37 | * Randomness 38 | 39 | 40 | # Related work 41 | 42 | * Work by Pieter and Tom 43 | * Reanimate library. Only for animations, not polymorphic. Has an incredible 44 | number of integrations with blender and many other animations frameworks. 45 | https://reanimate.readthedocs.io/en/latest/glue_tut/ 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /paper/haskell2020/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: [] 3 | 4 | extra-deps: 5 | - ../.. 6 | - git: git@github.com:diagrams/diagrams-lib.git 7 | commit: d3afa2f41bfb416be5713c033e3cd5a6eecd724a 8 | - git: git@github.com:diagrams/diagrams-rasterific.git 9 | commit: 51ebbff6873ecf021d7fac7a878cd05d45691520 10 | 11 | - diagrams-builder-0.8.0.5 12 | - diagrams-pgf-1.4.1.1 13 | - texrunner-0.0.1.2 14 | - haskell-src-exts-1.22.0 15 | - haskell-src-exts-simple-1.22.0.0 16 | 17 | # - diagrams-pgf-1.4 18 | # - palette-0.1.0.5 19 | # - diagrams-core-1.4.0.1 20 | # - diagrams-contrib-1.4.1 21 | # - shake-0.16 22 | # - lhs2tex-1.20 23 | # - SVGFonts-1.6.0.3 24 | 25 | flags: 26 | diagrams-builder: 27 | pgf: true 28 | -------------------------------------------------------------------------------- /src/Active/Duration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Active.Duration 9 | -- Copyright : (c) 2017 Brent Yorgey 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : byorgey@gmail.com 12 | -- 13 | -- Finite and infinite durations. 14 | ----------------------------------------------------------------------------- 15 | 16 | module Active.Duration 17 | ( -- * Duration 18 | 19 | Duration(..), Dur, isForever 20 | 21 | -- * Conversion 22 | 23 | , toDuration, fromDuration 24 | 25 | -- * Operations 26 | 27 | , subDuration 28 | 29 | ) where 30 | 31 | import Linear.Vector 32 | 33 | #if !MIN_VERSION_base(4,8,0) 34 | import Control.Applicative 35 | #endif 36 | 37 | ------------------------------------------------------------ 38 | -- Durations 39 | ------------------------------------------------------------ 40 | 41 | -- | The type of (potentially infinite) /durations/ over a given 42 | -- numeric type @n@. The infinite duration is longer than any finite 43 | -- duration. 44 | data Duration :: * -> * where 45 | 46 | -- | A finite duration of a given nonnegative length. The length 47 | -- can be zero. 48 | Duration :: n -> Duration n 49 | 50 | -- | An infinite duration. 51 | Forever :: Duration n 52 | 53 | deriving (Show, Eq, Ord, Functor) 54 | 55 | -- | @Duration Rational@ is common enough that it's worth giving it a 56 | -- short type synonym for convenience. 57 | type Dur = Duration Rational 58 | 59 | instance Applicative Duration where 60 | pure = Duration 61 | Forever <*> _ = Forever 62 | _ <*> Forever = Forever 63 | Duration f <*> Duration x = Duration (f x) 64 | 65 | -- | Durations inherit the additive structure of the underlying 66 | -- numeric type; the sum of the infinite duration with anything is 67 | -- infinite. Note that it does not make sense to multiply durations, 68 | -- but you can scale them by a constant using the ('*^') operator 69 | -- from the 'Additive' instance. 70 | -- 71 | -- This instance also gives us the convenience of 'fromInteger', so 72 | -- numeric literals can be used as finite durations. 73 | instance Num n => Num (Duration n) where 74 | fromInteger = toDuration . fromInteger 75 | 76 | Forever + _ = Forever 77 | _ + Forever = Forever 78 | Duration d1 + Duration d2 = Duration (d1 + d2) 79 | 80 | abs Forever = Forever 81 | abs (Duration n) = Duration (abs n) 82 | 83 | (*) = error "Multiplying durations makes no sense. Use (*^) to scale by a constant." 84 | negate = error "Negating durations makes no sense." 85 | signum = error "Signum on durations makes no sense." 86 | 87 | instance Additive Duration where 88 | zero = Duration 0 89 | 90 | isForever :: Duration n -> Bool 91 | isForever Forever = True 92 | isForever _ = False 93 | 94 | -- | A wrapper function to convert a numeric value into a finite duration. 95 | toDuration :: n -> Duration n 96 | toDuration = Duration 97 | 98 | -- | An unwrapper function to turn a duration into a numeric value. 99 | -- Finite durations become @Just@; the infinite duration becomes 100 | -- @Nothing@. 101 | fromDuration :: Duration n -> Maybe n 102 | fromDuration Forever = Nothing 103 | fromDuration (Duration n) = Just n 104 | 105 | -- | Subtract a finite duration from another duration. If the first 106 | -- duration is infinite, the result is also infinite. If the second 107 | -- duration is longer than the first, the result is zero. 108 | subDuration :: (Num n, Ord n) => Duration n -> Duration n -> Duration n 109 | subDuration Forever _ = Forever 110 | subDuration (Duration a) (Duration b) | b <= a = Duration (a - b) 111 | subDuration _ _ = Duration 0 112 | 113 | -------------------------------------------------------------------------------- /src/Active/Ray.hs: -------------------------------------------------------------------------------- 1 | -- XXX todo: clean up, make module header etc. 2 | 3 | module Active.Ray where 4 | 5 | import Active.Duration 6 | import Data.Ratio 7 | 8 | -- | @Ray c d k p@ represents an arithmetic progression of points in 9 | -- time (i.e. regular samples), contained in a closed interval 10 | -- beginning at @c@ with duration @d@. @p@ is the "phase shift", so 11 | -- that the first sample is at @c + p@. In general, the samples are 12 | -- at @c + p + kt@ for natural numbers @t@. 13 | -- 14 | -- More abstractly, a @Ray@ represents an affine transformation of 15 | -- some initial segment of \([0,\infty)\) plus a phase shift @p@. 16 | -- 17 | -- Invariants: \(0 \leq |p| < |k|\); k and p have the same sign. 18 | data Ray = Ray Rational (Duration Rational) Rational Rational 19 | deriving Show 20 | 21 | rayPoints :: Ray -> [Rational] 22 | rayPoints (Ray c Forever k p) = map (\t -> p + k*t + c) $ [0 ..] 23 | rayPoints (Ray c (Duration d) k p) = takeWhile (\r -> abs (r - c) <= d) 24 | . map (\t -> p + k*t + c) 25 | $ [0 ..] 26 | 27 | primRay :: Dur -> Ray 28 | primRay d = Ray 0 d 1 0 29 | 30 | cutRay :: Dur -> Ray -> Ray 31 | cutRay x (Ray c d k p) = Ray c (x `min` d) k p 32 | 33 | rmod :: Rational -> Rational -> Rational 34 | rmod r m = r - m * fromIntegral (floor (r/m)) 35 | 36 | -- Drop an initial segment of length x from a ray. 37 | -- Assumption: x <= duration of the ray. 38 | omitRay :: Rational -> Ray -> Ray 39 | omitRay x (Ray c d k p) 40 | = Ray (c + offset) 41 | -- The new starting point is x distance from c. 42 | 43 | (d `subDuration` Duration x) 44 | -- The new duration is just the old duration - x. 45 | 46 | k 47 | -- The scaling factor is unaffected. 48 | 49 | ((p - offset) `rmod` k) 50 | -- The new phase shift is the old phase shift minus the 51 | -- offset, mod k. 52 | where 53 | offset = signum k * x 54 | -- The actual offset is in a direction determined by the sign of 55 | -- k. 56 | 57 | -- XXX 58 | offsetRay :: Rational -> Ray -> Ray 59 | offsetRay x (Ray c d k p) = Ray (c + x) d k p 60 | 61 | splitRay :: Rational -> Ray -> (Ray, Ray) 62 | splitRay x r = (cutRay (Duration x) r, offsetRay (-x) (omitRay x r)) 63 | 64 | -- Assume d is Finite. 65 | reverseRay :: Ray -> Ray 66 | reverseRay (Ray c (Duration d) k p) = Ray (c + d * signum k) (Duration d) (-k) p' 67 | where 68 | p' = abs (d - p) `rmod` abs k 69 | 70 | stretchRay :: Rational -> Ray -> Ray 71 | stretchRay r (Ray c d k p) = Ray c ((/r) <$> d) (k/r) (p/r) 72 | 73 | -- Check whether the given rational is contained in the ray 74 | onRay :: Rational -> Ray -> Bool 75 | onRay x (Ray c d k p) = 76 | -- check sign of k. 77 | -- - if k > 0 then c <= x <= c + d 78 | -- - otherwise c - d <= x <= c 79 | -- also need x == c + p + kt for some integer t. 80 | -- hence compute (x - c - p) / k and check whether it is integer. 81 | upperBound && lowerBound && (denominator ((x - c - p) / k) == 1) 82 | where 83 | upperBound = case d of 84 | Duration d' 85 | | k > 0 -> x <= c + d' 86 | | k < 0 -> c - d' <= x 87 | Forever -> True 88 | lowerBound 89 | | k > 0 = c <= x 90 | | k < 0 = x <= c 91 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-14.20 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | 11 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 12 | extra-deps: 13 | - git: git@github.com:diagrams/diagrams-lib.git 14 | commit: d3afa2f41bfb416be5713c033e3cd5a6eecd724a 15 | - git: git@github.com:diagrams/diagrams-rasterific.git 16 | commit: 51ebbff6873ecf021d7fac7a878cd05d45691520 17 | 18 | # Override default flag values for local packages and extra-deps 19 | flags: {} 20 | 21 | # Extra package databases containing global packages 22 | extra-package-dbs: [] 23 | 24 | # Control whether we use the GHC we find on the path 25 | # system-ghc: true 26 | 27 | # Require a specific version of stack, using version ranges 28 | # require-stack-version: -any # Default 29 | # require-stack-version: >= 1.0.0 30 | 31 | # Override the architecture used by stack, especially useful on Windows 32 | # arch: i386 33 | # arch: x86_64 34 | 35 | # Extra directories used by stack for building 36 | # extra-include-dirs: [/path/to/dir] 37 | # extra-lib-dirs: [/path/to/dir] 38 | 39 | # Allow a newer minor version of GHC than the snapshot specifies 40 | # compiler-check: newer-minor 41 | -------------------------------------------------------------------------------- /test/Laws.hs: -------------------------------------------------------------------------------- 1 | module Laws where 2 | 3 | -- getDuration laws 4 | getDuration (activeF d x) = d 5 | getDuration (activeI x) = Forever 6 | getDuration (active d x) = d 7 | getDuration (instant x) = 0 8 | getDuration (lasting d x) = d 9 | getDuration (always x) = Forever 10 | getDuration (ui) = 1 11 | getDuration (interval c d) = abs (d - c) 12 | getDuration (dur) = Forever 13 | getDuration (discreteNE xs) = 1 14 | getDuration (discrete xs) = 1 15 | 16 | getDuration (cut d x) = min d (getDuration x) 17 | getDuration (omit d x) = getDuration x - d {d <= getDuration x} 18 | getDuration (omit d x) + d = getDuration x 19 | 20 | -- if we have Monoid a => Active a, we could define: 21 | -- getDuration (omit d x) = max 0 (getDuration x - d) 22 | -- i.e. omit d x returns instant mempty when d > getDuration x 23 | 24 | -- Should there be a total version of omit for Monoid provided? 25 | -- Maybe non-total, non-Monoid version is 'unsafe' version? 26 | 27 | getDuration (backwards x) = getDuration x {x is finite?} 28 | getDuration (always x) = Forever 29 | 30 | getDuration (stretch k x) = |k| * getDuration x {k /= 0} 31 | 32 | getDuration (x ->- y) = getDuration x + getDuration y 33 | 34 | cutTo x y = cut (getDuration x) y 35 | 36 | cut d x ->- omit d x = x 37 | if d <= getDuration x 38 | 39 | omit (c + d) x = (omit c . omit d) x {c + d <= getDuration x} 40 | 41 | cut c . cut d = cut (min c d) 42 | 43 | cut (c + d) x = cut c x ->- cut d (omit c x) {c <= getDuration x} 44 | 45 | cut d x = x 46 | -- if d >= getDuration x 47 | 48 | slice a b x 49 | | a <= b = cut (b - a) (omit a x) 50 | | otherwise = backwards (slice b a x) 51 | 52 | backwards (backwards x) = x {x is finite} 53 | stretch (-1) x = backwards x 54 | 55 | stretch (j*k) = stretch j . stretch k {j, k /= 0} 56 | 57 | snapshot t x = always (runActive t x) 58 | 59 | delay d x = lasting d mempty ->- x 60 | 61 | lasting d x = cut d (always x) 62 | 63 | (x ->- y) ->- z = x ->- (y ->- z) 64 | instant mempty ->- y = y 65 | x ->- instant mempty = x 66 | 67 | backwards (x ->- y) = backwards y ->- backwards x 68 | -- if we have a commutative semigroup 69 | 70 | omit (getDuration x) (x ->> y) = y 71 | -- if x finite 72 | 73 | omit Forever x = empty 74 | -- provisional: we have no notion of empty 75 | 76 | cut (getDuration x) x ->> y = y 77 | 78 | cut d (x ->> y) = x ->> cut (d - getDuration x) y 79 | -- if d >= getDuration x 80 | 81 | cut d (x ->> y) = x 82 | -- if d < getDuration x 83 | -------------------------------------------------------------------------------- /test/active-doctest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Data.Foldable (traverse_) 5 | import System.Environment (unsetEnv) 6 | import Test.DocTest (doctest) 7 | 8 | main :: IO () 9 | main = do 10 | traverse_ putStrLn args 11 | -- This variable is set automatically by Stack, and read by GHC when 12 | -- executed by doctest; we don't want that. 13 | unsetEnv "GHC_ENVIRONMENT" 14 | doctest args 15 | where 16 | args = flags ++ pkgs ++ module_sources 17 | --------------------------------------------------------------------------------