diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/extra/fudi2midi.pd b/extra/fudi2midi.pd new file mode 100644 --- /dev/null +++ b/extra/fudi2midi.pd @@ -0,0 +1,59 @@ +#N canvas 0 0 547 342 10; +#X obj 28 2 netreceive 8765; +#X obj 29 172 noteout; +#X msg 29 127 \$2 \$3 \$1; +#X msg 35 148 \$2 0 \$1; +#X obj 109 173 pgmout; +#X msg 109 150 \$2 \$1; +#X obj 176 173 ctlout; +#X msg 177 150 \$3 \$2 \$1; +#X msg 242 150 \$2 \$1; +#X obj 242 171 touchout; +#X msg 315 148 \$3 \$2 \$1; +#X obj 315 169 polytouchout; +#X msg 398 148 \$2 \$1; +#X obj 398 169 bendout; +#X obj 371 84 spigot; +#X obj 404 18 tgl 15 0 empty empty empty 17 7 0 10 -262144 -1 -1 1 +1; +#X obj 158 1 print connection; +#X obj 371 105 print unhandled; +#X obj 416 44 spigot; +#X obj 447 16 tgl 15 0 empty empty empty 17 7 0 10 -262144 -1 -1 0 +1; +#X obj 418 65 print debug; +#X obj 29 48 route noteon noteoff program control pressure touch bend +rebound; +#X floatatom 116 29 5 0 0 0 - - -; +#X obj 300 12 route rebound; +#X obj 296 36 print midi; +#X obj 297 -7 spigot; +#X obj 342 -5 tgl 15 0 empty empty empty 17 7 0 10 -262144 -1 -1 1 +1; +#X connect 0 0 18 0; +#X connect 0 0 21 0; +#X connect 0 0 25 0; +#X connect 0 1 16 0; +#X connect 0 1 22 0; +#X connect 2 0 1 0; +#X connect 3 0 1 0; +#X connect 5 0 4 0; +#X connect 7 0 6 0; +#X connect 8 0 9 0; +#X connect 10 0 11 0; +#X connect 12 0 13 0; +#X connect 14 0 17 0; +#X connect 15 0 14 1; +#X connect 18 0 20 0; +#X connect 19 0 18 1; +#X connect 21 0 2 0; +#X connect 21 1 3 0; +#X connect 21 2 5 0; +#X connect 21 3 7 0; +#X connect 21 4 8 0; +#X connect 21 5 10 0; +#X connect 21 6 12 0; +#X connect 21 8 14 0; +#X connect 23 1 24 0; +#X connect 25 0 23 0; +#X connect 26 0 25 1; diff --git a/gulcii.cabal b/gulcii.cabal new file mode 100644 --- /dev/null +++ b/gulcii.cabal @@ -0,0 +1,84 @@ +Name: gulcii +Version: 0.2.0.1 +Synopsis: graphical untyped lambda calculus interactive interpreter +Description: + GULCII is an untyped lambda calculus interpreter supporting interactive + modification of a running program with graphical display of graph reduction. + . + There are three variants of lambda abstraction: lazy, strict, and copy: + . + @> \x . f x x -- x is evaluated lazily with sharing@ + @> \x ! f x x -- x is evaluated strictly and shared@ + @> \x ? f x x -- x is copied before any evaluation@ + . + There is additional syntax sugar for natural numbers and lists, using + : + . + @> [0,1,2,3]@ + . + There is a small standard library based loosely around the Haskell Prelude, + with additions geared towards MIDI generation for live-coding music, implemented + using a mechanism similar to 'Debug.Trace.trace': + . + @> \x y . { print : x } y@ + . + Quick start: + . + > gulcii + > :load mars.gu + > main + > :quit + . + If you have Pure-data and Timidity, try: + . + > timidity -iA -Oj & + > pd -alsamidi ~/.cabal/share/gulcii-0.2.0.1/extra/fudi2midi.pd & + > gulcii | pdsend 8765 + . + See also: live-sequencer which has many more features (but no sharing during + evaluation). + +Homepage: http://gitorious.org/maximus/gulcii +License: GPL-2 +License-file: LICENSE +Author: Claude Heiland-Allen +Maintainer: claude@mathr.co.uk +Category: Sound, Music, GUI +Build-type: Simple +Cabal-version: >=1.6 +Tested-With: GHC==7.6.2 + +Data-files: extra/fudi2midi.pd, + lib/bits.gu, + lib/bool.gu, + lib/either.gu, + lib/event.gu, + lib/function.gu, + lib/list.gu, + lib/maybe.gu, + lib/midi.gu, + lib/natural.gu, + lib/pair.gu, + lib/prelude.gu, + lib/mars.gu + +Executable gulcii + HS-source-dirs: src + Main-is: Main.hs + Build-depends: base >= 3 && < 6, + containers >= 0.3 && < 0.6, + filepath >= 1.1 && < 1.4, + gtk >= 0.11 && < 0.13, + cairo >= 0.11 && < 0.13 + Other-modules: Bruijn Command Draw Evaluation Graph Lambda Layout Meta Parse Sugar + ghc-options: -Wall -threaded -rtsopts + ghc-prof-options: -prof -auto-all -caf-all + +Source-Repository head + Type: git + Location: git://gitorious.org/maximus/gulcii.git + +Source-Repository this + Type: git + Tag: 0.2.0.1 + Location: git://gitorious.org/maximus/gulcii.git diff --git a/lib/bits.gu b/lib/bits.gu new file mode 100644 --- /dev/null +++ b/lib/bits.gu @@ -0,0 +1,10 @@ +# Data.Bits(Bits( +# (.&.), (.|.), xor, complement, +# bit, setBit, clearBit, complementBit, testBit, +# shift, shiftL, shiftR, rotate, rotateL, rotateR, +# bitSize, isSigned )) +# bits +bits@and = zipWith and +bits@or = zipWith or +bits@xor = zipWith xor +bits@not = map not diff --git a/lib/bool.gu b/lib/bool.gu new file mode 100644 --- /dev/null +++ b/lib/bool.gu @@ -0,0 +1,6 @@ +# boolean +false = \ t f . f +true = \ t f . t +and = \ a b . a b a +or = \ a b . a a b +not = \ a . a false true diff --git a/lib/either.gu b/lib/either.gu new file mode 100644 --- /dev/null +++ b/lib/either.gu @@ -0,0 +1,4 @@ +# either +left = \ a l r . l a +right = \ b l r . r b +either = \ ac bc e . e ac bc diff --git a/lib/event.gu b/lib/event.gu new file mode 100644 --- /dev/null +++ b/lib/event.gu @@ -0,0 +1,6 @@ +# event +wait = \n w e . w n +event = \x w e . e x +merge = \al bl . al (\a as . bl (\b bs . a (\aw . b (\bw . lessthan aw bw (cons a (merge as (cons (wait (sub bw aw)) bs))) (cons b (merge (cons (wait (sub aw bw)) as) bs))) (\e . cons b (merge al bs))) (\e . cons a (merge as bl))) al) bl +merges = foldr merge nil +play = \l . l (\x xs . x (\w . { wait : w } (play xs)) (\e . e (play xs))) (error play) diff --git a/lib/function.gu b/lib/function.gu new file mode 100644 --- /dev/null +++ b/lib/function.gu @@ -0,0 +1,9 @@ +# function +id = \ a . a +const = \ a b . a +compose = \ bc ab a . bc (ab a) +flip = \ abc b a . abc a b +fix = \ f . f (fix f) +undefined = undefined +error = \e . error e +seq = \ a ! \b . b diff --git a/lib/list.gu b/lib/list.gu new file mode 100644 --- /dev/null +++ b/lib/list.gu @@ -0,0 +1,52 @@ +# module Data.List ( +# (++), head, last, tail, init, null, length, map, reverse, +# intersperse, intercalate, transpose, subsequences, permutations, +# foldl, foldl', foldl1, foldl1', foldr, foldr1, concat, concatMap, +# and, or, any, all, sum, product, maximum, minimum, scanl, scanl1, +# scanr, scanr1, mapAccumL, mapAccumR, iterate, repeat, replicate, +# cycle, unfoldr, take, drop, splitAt, takeWhile, dropWhile, span, +# break, stripPrefix, group, inits, tails, isPrefixOf, isSuffixOf, +# isInfixOf, elem, notElem, lookup, find, filter, partition, (!!), +# elemIndex, elemIndices, findIndex, findIndices, zip, zip3, zip4, +# zip5, zip6, zip7, zipWith, zipWith3, zipWith4, zipWith5, zipWith6, +# zipWith7, unzip, unzip3, unzip4, unzip5, unzip6, unzip7, lines, +# words, unlines, unwords, nub, delete, (\\), union, intersect, sort, +# insert, nubBy, deleteBy, deleteFirstsBy, unionBy, intersectBy, +# groupBy, sortBy, insertBy, maximumBy, minimumBy, genericLength, +# genericTake, genericDrop, genericSplitAt, genericIndex, genericReplicate +# ) where +# list +nil = \ c n . n +cons = \ x xs c n . c x xs +null = \ l . l (\x xs . false) true +head = \ l . l (\x xs . x) (error head) +tail = \ l . l (\x xs . xs) (error tail) +map = \ f l . l (\x xs . cons (f x) (map f xs)) nil +append = \ us vs . us (\x xs . cons x (append xs vs)) vs +filter = \ p l . l (\x xs . p x (cons x) id (filter p xs)) nil +index = \ l n . n (\p . l (\x xs . index xs p) (error index)) (l (\x xs . x) (error index)) +reverse = \ l . l (\x xs . append (reverse xs) (cons x nil)) nil +foldr = \ f e l . l (\x xs . f x (foldr f e xs)) e +length = foldr (const succ) zero +ands = foldr and true +ors = foldr or false +concat = foldr append nil +all = \f . compose ands (map f) +any = \f . compose ors (map f) +concatMap = \f . compose concat (map f) +composes = foldr compose id +sum = foldr add zero +product = foldr mul (succ zero) +repeat = \x . cons x (repeat x) +cycle = compose concat repeat +zipWith = \f l r . l (\x xs . r (\y ys . cons (f x y) (zipWith f xs ys)) nil) nil +partition = \p l . l (\x xs . p x first second (cons x) (partition p xs)) (pair nil nil) +partitionEithers = \l . l (\e es . e (compose first cons) (compose second cons) (partitionEithers es)) (pair nil nil) +take = \n l . n (\p . l (\x xs . cons x (take p xs)) nil) nil +drop = \n l . n (\p . l (\x xs . drop p xs) nil) l +transpose = \l . l (\xs xss . xs (\y ys . cons (cons y (concatMap (take 1) xss)) (transpose (cons ys (map (drop 1) xss)))) (transpose xss)) nil +catMaybes = \l . l (\x xs . maybe id cons x (catMaybes xs)) nil +iterate = \f . \x ! cons x (iterate f (f x)) +last = \l . l (\x xs . xs (\y ys . last xs) x) (error last) +replicate = \n x . take n (repeat x) +rotate = \n bs . splitAt n bs \xs ys . append ys xs diff --git a/lib/mars.gu b/lib/mars.gu new file mode 100644 --- /dev/null +++ b/lib/mars.gu @@ -0,0 +1,5 @@ +:load prelude +main = play (cons (event (program 0 48)) timpanis) +timpanis = append timpani timpanis +timpani = concatMap makeNote [20,20,20,60,60,30,30,60] +makeNote = \d ! note d 0 43 96 diff --git a/lib/maybe.gu b/lib/maybe.gu new file mode 100644 --- /dev/null +++ b/lib/maybe.gu @@ -0,0 +1,8 @@ +# module Data.Maybe ( +# Maybe(Nothing, Just), maybe, isJust, isNothing, fromJust, fromMaybe, +# listToMaybe, maybeToList, catMaybes, mapMaybe +# ) where instance Monad Functor MonadPlus Eq Ord Read Show +# maybe +nothing = \ j n . n +just = \ a j n . j a +maybe = \ b ab m . m ab b diff --git a/lib/midi.gu b/lib/midi.gu new file mode 100644 --- /dev/null +++ b/lib/midi.gu @@ -0,0 +1,7 @@ +# midi +noteOn = \c n v ! \x . { noteon : [c, n, v] } x +noteOff = \c n v ! \x . { noteoff : [c, n, v] } x +program = \c p ! \x . { program : [c, p] } x +control = \c p v ! \x . { control : [c, p, v] } x +note = \d ! \c n v . [ event (noteOn c n v), wait d, event (noteOff c n v) ] +rest = \d ! [ wait d ] diff --git a/lib/natural.gu b/lib/natural.gu new file mode 100644 --- /dev/null +++ b/lib/natural.gu @@ -0,0 +1,11 @@ +# natural +zero = \ s z . z +succ = \ n s z . s n +infinity = succ infinity +even = \n . n odd true +odd = \n . n even false +add = \ m n . m (\p . succ (add n p)) n +mul = \ m n . m (\p . add n (mul n p)) zero +sub = \ m n . m (\p . n (sub p) m) zero +equal = \ m n . m (\mm . n (\nn . equal mm nn) false) (n (\nn . false) true) +lessThan = \x y . x (\xx . y (\yy . lessThan xx yy) false) (y (\yy . true) false) diff --git a/lib/pair.gu b/lib/pair.gu new file mode 100644 --- /dev/null +++ b/lib/pair.gu @@ -0,0 +1,9 @@ +# pair +pair = \ a b p . p a b +fst = \ p . p \ a b . a +snd = \ p . p \ a b . b +curry = \ f a b . f (pair a b) +uncurry = \ f p . f (fst p) (snd p) +swap = \p . pair (snd p) (fst p) +first = \f p . pair (f (fst p)) (snd p) +second = \ f p . pair (fst p) (f (snd p)) diff --git a/lib/prelude.gu b/lib/prelude.gu new file mode 100644 --- /dev/null +++ b/lib/prelude.gu @@ -0,0 +1,10 @@ +:load bits +:load bool +:load either +:load event +:load function +:load list +:load maybe +:load midi +:load natural +:load pair diff --git a/src/Bruijn.hs b/src/Bruijn.hs new file mode 100644 --- /dev/null +++ b/src/Bruijn.hs @@ -0,0 +1,76 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Bruijn (Term(..), bruijn, freeVariablesIn, bind) where + +import Data.Maybe (listToMaybe) +import Data.Set (Set, empty, singleton, union) + +import qualified Lambda as U +import Evaluation (Strategy) + +data Term + = Free String + | Bound Integer + | Lambda Strategy Term + | Apply Term Term + | Trace String Term Term + deriving (Read, Show, Eq, Ord) + +bruijn :: U.Term -> Term +bruijn = bruijn' [] + +bruijn' :: [String] -> U.Term -> Term +bruijn' m (U.Apply s t) = Apply (bruijn' m s) (bruijn' m t) +bruijn' m (U.Lambda k v t) = Lambda k (bruijn' (v : m) t) +bruijn' m (U.Variable v) = + case genericElemIndex v m of + Nothing -> Free v + Just i -> Bound i +bruijn' m (U.Trace k s t) = Trace k (bruijn' m s) (bruijn' m t) + +bind :: Strategy -> String -> Term -> Term +bind k v t = Lambda k (bind' 0 v t) + +bind' :: Integer -> String -> Term -> Term +bind' i v f@(Free u) = if u == v then Bound i else f +bind' _ _ b@(Bound _) = b +bind' i v (Apply s t) = Apply (bind' i v s) (bind' i v t) +bind' i v (Lambda _ t) = bind' (i + 1) v t +bind' i v (Trace k s t) = Trace k (bind' i v s) (bind' i v t) + +freeVariablesIn :: Term -> Set String +freeVariablesIn (Free v) = singleton v +freeVariablesIn (Bound _) = empty +freeVariablesIn (Lambda _ t) = freeVariablesIn t +freeVariablesIn (Apply s t) = freeVariablesIn s `union` freeVariablesIn t +freeVariablesIn (Trace _ s t) = freeVariablesIn s `union` freeVariablesIn t + +{- +Generic list functions. +-} + +genericElemIndex :: (Eq a, Enum b, Num b) => a -> [a] -> Maybe b +genericElemIndex x = genericFindIndex (x ==) + +genericFindIndex :: (Enum b, Num b) => (a -> Bool) -> [a] -> Maybe b +genericFindIndex p = listToMaybe . genericFindIndices p + +genericFindIndices :: (Enum b, Num b) => (a -> Bool) -> [a] -> [b] +genericFindIndices p xs = [ i | (x, i) <- zip xs [0 ..], p x] diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 --- /dev/null +++ b/src/Command.hs @@ -0,0 +1,35 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Command (Command(..), parse) where + +import Control.Applicative ((<$>), (<*>), (<$), (<*), (<|>)) + +import qualified Sugar as S +import qualified Meta as M +import Parse + +data Command = Define String S.Term | Evaluate S.Term | Execute S.Term | Meta M.Meta + deriving (Read, Show, Eq, Ord) + +parse :: Parser String Command +parse = (Define <$> name <* sym "=" <*> S.parse) + <|> (Evaluate <$> S.parse) + <|> (Execute <$ sym "~" <*> S.parse) + <|> (Meta <$ sym ":" <*> M.parse) diff --git a/src/Draw.hs b/src/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Draw.hs @@ -0,0 +1,147 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Draw (draw) where + +import Data.List (genericDrop) +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) + +import Graphics.Rendering.Cairo + +import qualified Layout as L +import Evaluation (Strategy(..)) + +type RGB = (Double, Double, Double) + +colour :: L.Term -> RGB +colour (L.Free _ _) = (0, 0.5, 1) +colour (L.Bound _ _) = (0.5, 0, 1) +colour (L.Lambda Strict _ _) = (1, 0, 0) +colour (L.Lambda Lazy _ _) = (1, 0, 0.5) +colour (L.Lambda Copy _ _) = (1, 0, 1) +colour (L.Apply _ _ _) = (1, 0.5, 0) +colour (L.RefInst _ _ _) = (0.5, 1, 0) +colour (L.Reference _ _) = (0, 1, 0.5) +colour (L.Trace _ _ _ _) = (1, 1, 0) + +circle :: L.Coords -> RGB -> Render () +circle (x, y) (r, g, b) = do + save + translate (fromIntegral x) (fromIntegral y) + arc 0 0 0.365 0 (2*pi) + setSourceRGB r g b + fillPreserve + setSourceRGB 0 0 0 + stroke + restore + +line :: L.Coords -> L.Coords -> Render () +line (x, y) (x', y') = do + save + moveTo (fromIntegral x ) (fromIntegral y ) + lineTo (fromIntegral x') (fromIntegral y') + stroke + restore + +draw :: Double -> Double -> L.Layout -> Render () +draw ww0 hh0 (L.Layout t w h ps) = do + save + translate dx dy + scale s s + translate 0.5 0.5 + setLineWidth 0.1 + setSourceRGB 0 0 0 + drawLinks ps t + drawNodes t + setLineCap LineCapRound + setSourceRGB 0.5 0.5 0.5 + drawVLinks [] t + setFontSize (6 / sqrt s) + translate 0 0.5 + drawNames t + setSourceRGB 0 0 0 + fillPreserve + setLineWidth (0.2 / sqrt s) + setSourceRGB 1 1 1 + stroke + restore + where + s = if fromIntegral w * hh <= fromIntegral h * ww then hh / fromIntegral h else ww / fromIntegral w + ww = ww0 - 128 + hh = hh0 - 64 + dx = (ww0 - s * fromIntegral w) / 2 + dy = (hh0 - s * fromIntegral h) / 2 + +drawNames :: L.Term -> Render () +drawNames (L.Free s (x,y)) = do + e <- textExtents s + moveTo (fromIntegral x - textExtentsWidth e / 2) (fromIntegral y) + textPath s +drawNames (L.Bound _ _) = return () +drawNames (L.Lambda _ t _) = drawNames t +drawNames (L.Apply a b _) = drawNames a >> drawNames b +drawNames (L.RefInst _ t _) = drawNames t +drawNames (L.Reference _ _) = return () +drawNames (L.Trace s a b (x,y)) = do + e <- textExtents s + moveTo (fromIntegral x - textExtentsWidth e / 2) (fromIntegral y) + textPath s + drawNames a + drawNames b + +drawLinks :: Map Integer L.Coords -> L.Term -> Render () +drawLinks _ (L.Free _ _) = return () +drawLinks _ (L.Bound _ _) = return () +drawLinks ps (L.Lambda _ t xy) = let x'y' = L.coordinates t + in line xy x'y' >> drawLinks ps t +drawLinks ps (L.Apply a b xy) = let axay = L.coordinates a + bxby = L.coordinates b + in line xy axay >> line xy bxby >> drawLinks ps a >> drawLinks ps b +drawLinks ps (L.RefInst _ t xy) = let x'y' = L.coordinates t + in line xy x'y' >> drawLinks ps t +drawLinks ps (L.Reference p xy) = let Just x'y' = M.lookup p ps + in line xy x'y' +drawLinks ps (L.Trace _ a b xy) = + let axay = L.coordinates a + bxby = L.coordinates b + in line xy axay >> line xy bxby >> drawLinks ps a >> drawLinks ps b + +drawVLinks :: [L.Coords] -> L.Term -> Render () +drawVLinks ls (L.Bound n xy) = + case genericDrop n ls of + [] -> return () + x'y':_ -> line xy x'y' +drawVLinks ls (L.Lambda _ t xy) = drawVLinks (xy : ls) t +drawVLinks ls (L.Apply s t _) = drawVLinks ls s >> drawVLinks ls t +drawVLinks ls (L.RefInst _ t _) = drawVLinks ls t +drawVLinks ls (L.Trace _ s t _) = drawVLinks ls s >> drawVLinks ls t +drawVLinks _ _ = return () + +drawNodes :: L.Term -> Render () +drawNodes n@(L.Free _ _) = drawNode n +drawNodes n@(L.Bound _ _) = drawNode n +drawNodes n@(L.Lambda _ t _) = drawNode n >> drawNodes t +drawNodes n@(L.Apply a b _) = drawNode n >> drawNodes a >> drawNodes b +drawNodes n@(L.RefInst _ t _) = drawNode n >> drawNodes t +drawNodes n@(L.Reference _ _) = drawNode n +drawNodes n@(L.Trace _ a b _) = drawNode n >> drawNodes a >> drawNodes b + +drawNode :: L.Term -> Render () +drawNode n = circle (L.coordinates n) (colour n) diff --git a/src/Evaluation.hs b/src/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Evaluation.hs @@ -0,0 +1,23 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Evaluation (Strategy(..)) where + +data Strategy = Lazy | Strict | Copy + deriving (Read, Show, Eq, Ord) diff --git a/src/Graph.hs b/src/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Graph.hs @@ -0,0 +1,148 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Graph (Term(..), Definitions, References, Reduction(..), graph, reduce, pretty) where + +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) + +import qualified Bruijn as B +import Evaluation (Strategy(..)) + +data Term + = Free !String + | Bound !Integer + | Lambda !Strategy !Term + | Apply !Term !Term + | Reference !Integer + | Trace !String !Term !Term + deriving (Read, Show, Eq, Ord) + +pretty :: Term -> String +pretty = unwords . pretty' + +pretty' :: Term -> [String] +pretty' (Free s) = [s] +pretty' (Bound i) = [show i] +pretty' (Reference i) = ['#':show i] +pretty' (Lambda k t) = ["(", "\\", pretty'' k] ++ pretty' t ++ [")"] +pretty' (Apply s t) = ["("] ++ pretty' s ++ pretty' t ++ [")"] +pretty' (Trace k s t) = ["(", "{", k, ":"] ++ pretty' s ++ ["}"] ++ pretty' t ++ [")"] + +pretty'' :: Strategy -> String +pretty'' Strict = "!" +pretty'' Lazy = "." +pretty'' Copy = "?" + +type Definitions = Map String Term +type References = Map Integer Term + +next :: Map Integer a -> Integer +next refs = case M.maxViewWithKey refs of + Nothing -> 0 + Just ((k,_),_) -> k + 1 + +graph :: B.Term -> Term +graph (B.Free v) = Free v +graph (B.Bound i) = Bound i +graph (B.Lambda k t) = Lambda k (graph t) +graph (B.Apply s t) = Apply (graph s) (graph t) +graph (B.Trace k s t) = Trace k (graph s) (graph t) + +{- +bind :: String -> Term -> Term -> Term +bind v s t@(Free u) = if u == v then s else t +bind _ _ t@(Bound _) = t +bind v s (Lambda k t) = Lambda k (bind v s t) +bind v s (Apply a b) = Apply (bind v s a) (bind v s b) +bind _ _ t@(Reference _) = t +-} + +{- +Reduce a graph one step, returning Nothing if it is irreducible. +-} + +data Reduction = Reduced Term References | Rebound String Term References | Traced String Term Term References + deriving (Read, Show, Eq, Ord) + +mapR :: (Term -> Term) -> Reduction -> Reduction +mapR f (Reduced t refs) = Reduced (f t) refs +mapR f (Rebound s t refs) = Rebound s (f t) refs +mapR f (Traced k s t refs) = Traced k s (f t) refs + +reduce, reduce' :: Definitions -> References -> Term -> Maybe Reduction +reduce _ refs (Trace k s t) = Just (Traced k s t refs) +reduce defs refs term = reduce' defs refs term + +-- free variables are replaced with their definition +reduce' defs refs (Free v) = case M.lookup v defs of + Nothing -> Nothing + Just t -> let r = next refs in Just (Rebound v (Reference r) (M.insert r t refs)) + +-- bound variables are irreducible +reduce' _ _ (Bound _) = Nothing + +-- non top-level traces are irreducible? +--reduce' _ _ (Trace _ _ _) = Nothing +reduce' _ refs (Trace k s t) = Just (Traced k s t refs) + +-- maybe reduce inside lambda +reduce' defs refs (Lambda k t) = mapR (Lambda k) `fmap` reduce' defs refs t + +reduce' defs refs (Apply a b) = case a of + -- beta reduction + Lambda Strict a' -> case reduce defs refs b of + Just r -> Just (mapR (a `Apply`) r) + Nothing -> Just (uncurry Reduced (beta refs a' b)) + Lambda Copy a' -> Just (Reduced (beta' 0 a' b) refs) + Lambda Lazy a' -> Just (uncurry Reduced (beta refs a' b)) + Reference r -> case M.lookup r refs of + Just a' -> Just (Reduced (Apply a' b) refs) + _ -> Nothing + Free s -> case M.lookup s defs of + Just a' -> Just (Rebound s (Apply a' b) refs) + _ -> Nothing + t@(Apply _ _) -> case reduce defs refs t of + Just r -> Just (mapR (`Apply` b) r) + _ -> Nothing + _ -> Nothing -- Bound, Trace + +-- reduce references +reduce' defs refs s@(Reference r) = case M.lookup r refs of + Nothing -> Nothing + Just t -> case reduce' defs refs t of + Just (Reduced t' refs') -> Just (Reduced s (M.insert r t' refs')) + Just (Rebound v t' refs') -> Just (Rebound v s (M.insert r t' refs')) + _ -> Just (Reduced t refs) + +-- beta reduction +beta :: References -> Term -> Term -> (Term, References) +beta refs a b = (beta' 0 a t, refs') + where + r = next refs + refs' = M.insert r b refs + t = Reference r + +beta' :: Integer -> Term -> Term -> Term +beta' i s@(Bound j) t = if i == j then t else s +beta' i (Lambda k s) t = Lambda k (beta' (i + 1) s t) +beta' i (Apply a b) t = Apply (beta' i a t) (beta' i b t) +beta' _ s@(Free _) _ = s +beta' _ s@(Reference _) _ = s +beta' i (Trace k a b) t = Trace k (beta' i a t) (beta' i b t) diff --git a/src/Lambda.hs b/src/Lambda.hs new file mode 100644 --- /dev/null +++ b/src/Lambda.hs @@ -0,0 +1,80 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Lambda (Term(..), pretty, isFreeIn, variablesIn, freeVariablesIn) where + +import Data.List (nub) + +import Evaluation (Strategy(..)) + +{- +Untyped lambda calculus terms. +-} + +data Term + = Variable String + | Lambda Strategy String Term + | Apply Term Term + | Trace String Term Term + deriving (Read, Show, Eq, Ord) + +{- +Pretty-print a term. +-} + +pretty :: Term -> String +pretty = unwords . pretty' + +pretty' :: Term -> [String] +pretty' (Variable v) = [v] +pretty' (Lambda k v t) = ["(", "\\", v, pretty'' k] ++ pretty' t ++ [")"] +pretty' (Apply s t) = ["("] ++ pretty' s ++ pretty' t ++ [")"] +pretty' (Trace k s t) = ["(", "{", k, ":"] ++ pretty' s ++ ["}"] ++ pretty' t ++ [")"] + +pretty'' :: Strategy -> String +pretty'' Strict = "!" +pretty'' Lazy = "." +pretty'' Copy = "?" + +{- +Check if a variable occurs free in a term. +-} + +isFreeIn :: String -> Term -> Bool +isFreeIn n (Variable v) = n == v +isFreeIn n (Lambda _ v t) = if n == v then False else n `isFreeIn` t +isFreeIn n (Apply t t') = n `isFreeIn` t || n `isFreeIn` t' +isFreeIn n (Trace _ t t') = n `isFreeIn` t || n `isFreeIn` t' + +{- +Get all variable names defined or referenced by a term. +-} + +variablesIn :: Term -> [String] +variablesIn (Variable v) = [v] +variablesIn (Lambda _ v t) = nub $ v : variablesIn t +variablesIn (Apply t t') = nub $ variablesIn t ++ variablesIn t' +variablesIn (Trace _ t t') = nub $ variablesIn t ++ variablesIn t' + +{- +Get all free variables referenced by a term. +-} + +freeVariablesIn :: Term -> [String] +freeVariablesIn t = filter (`isFreeIn` t) (variablesIn t) diff --git a/src/Layout.hs b/src/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Layout.hs @@ -0,0 +1,74 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Layout (Term(..), Coords, Layout(..), layout, coordinates) where + +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) + +import qualified Graph as G +import Evaluation (Strategy(..)) + +type Coords = (Integer, Integer) + +data Term + = Free String Coords + | Bound Integer Coords + | Lambda Strategy Term Coords + | Apply Term Term Coords + | RefInst Integer Term Coords + | Reference Integer Coords + | Trace String Term Term Coords + deriving (Read, Show, Eq, Ord) + +data Layout = Layout Term Integer Integer (Map Integer Coords) + deriving (Read, Show, Eq, Ord) + +coordinates :: Term -> Coords +coordinates (Free _ xy) = xy +coordinates (Bound _ xy) = xy +coordinates (Lambda _ _ xy) = xy +coordinates (Apply _ _ xy) = xy +coordinates (RefInst _ _ xy) = xy +coordinates (Reference _ xy) = xy +coordinates (Trace _ _ _ xy) = xy + +layout :: G.Term -> G.References -> Layout +layout = layout' (0, 0) M.empty + +layout' :: Coords -> Map Integer Coords -> G.Term -> G.References -> Layout +layout' xy ps (G.Free v) _ = Layout (Free v xy) 1 1 ps +layout' xy ps (G.Bound v) _ = Layout (Bound v xy) 1 1 ps +layout' (x,y) ps (G.Lambda k t) g = let Layout lt w h ps' = layout' (x, y + 1) ps t g + (px, _) = coordinates lt + in Layout (Lambda k lt (px, y)) w (h + 1) ps' +layout' (x,y) ps (G.Apply a b) g = let Layout la aw ah psa = layout' (x, y + 1) ps a g + Layout lb bw bh psb = layout' (x + aw + 1, y + 1) psa b g + in Layout (Apply la lb (x + aw, y)) (1 + aw + bw) (1 + (ah `max` bh)) psb +layout' xy@(x,y) ps (G.Reference p) g = if p `M.member` ps + then Layout (Reference p xy) 1 1 ps + else case M.lookup p g of + Nothing -> error $ "layout': bad pointer: " ++ show p + Just t -> let Layout lt w h pst = layout' (x, y + 1) ps t g + (px, py) = coordinates lt + in Layout (RefInst p lt (px, y)) w (1 + h) (M.insert p (px, py) pst) +layout' (x,y) ps (G.Trace s a b) g = + let Layout la aw ah psa = layout' (x, y + 1) ps a g + Layout lb bw bh psb = layout' (x + aw + 1, y + 1) psa b g + in Layout (Trace s la lb (x + aw, y)) (1 + aw + bw) (1 + (ah `max` bh)) psb diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,305 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Main (main) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, killThread, threadDelay, Chan, newChan, readChan, writeChan) +import Control.Monad (forever, when) +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef) +import System.IO (hSetBuffering, BufferMode(LineBuffering), stdout) +import System.IO.Error (catchIOError) +import System.FilePath ((), (<.>)) +import Graphics.UI.Gtk hiding (Meta) +import Graphics.Rendering.Cairo + +import Paths_gulcii (getDataFileName) + +import qualified Command as C +import qualified Meta as M +import qualified Sugar as S +import qualified Bruijn as B +import qualified Graph as G +import qualified Layout as L +import qualified Draw as D +import qualified Parse as P + +data Interpret = Fail | Skip | Define String G.Term | Pure G.Term | Run G.Term | Meta M.Meta + deriving (Read, Show, Eq, Ord) + +interpret :: String -> Interpret +interpret l = + case P.unP C.parse `fmap` P.tokenize (P.decomment l) of + Just ((C.Define d sterm, []):_) -> + case S.desugar sterm of + Just term -> Define d . G.graph . B.bruijn $ term + _ -> Fail + Just ((C.Evaluate sterm, []):_) -> + case S.desugar sterm of + Just term -> Pure . G.graph . B.bruijn $ term + _ -> Fail + Just ((C.Execute sterm, []):_) -> + case S.desugar sterm of + Just term -> Run . G.graph . B.bruijn $ term + _ -> Fail + Just ((C.Meta m, []):_) -> Meta m + Just [] -> Skip + _ -> Fail + +main :: IO () +main = do + _args <- initGUI + envR <- newIORef M.empty + lRef <- newIORef Nothing + evalR <- newIORef Nothing + outC <- newChan + _ <- forkIO $ outputter outC + let out = writeChan outC + win <- windowNew + _ <- onDestroy win mainQuit + windowSetDefaultSize win 1024 720 + vb <- vBoxNew False 0 + hb <- hPanedNew + tt <- textTagTableNew + tagInputRem <- textTagNew Nothing + tagInputDef <- textTagNew Nothing + tagInputPure <- textTagNew Nothing + tagInputRun <- textTagNew Nothing + tagInputMeta <- textTagNew Nothing + tagOutput <- textTagNew Nothing + tagOutputMeta <- textTagNew Nothing + tagError <- textTagNew Nothing + set tagInputRem [ textTagForeground := "cyan" ] + set tagInputDef [ textTagForeground := "green" ] + set tagInputPure [ textTagForeground := "yellow" ] + set tagInputRun [ textTagForeground := "orange" ] + set tagInputMeta [ textTagForeground := "blue" ] + set tagOutput [ textTagForeground := "magenta" ] + set tagOutputMeta [ textTagForeground := "pink" ] + set tagError [ textTagForeground := "red" ] + textTagTableAdd tt tagInputRem + textTagTableAdd tt tagInputDef + textTagTableAdd tt tagInputPure + textTagTableAdd tt tagInputRun + textTagTableAdd tt tagInputMeta + textTagTableAdd tt tagOutput + textTagTableAdd tt tagOutputMeta + textTagTableAdd tt tagError + tf <- textBufferNew (Just tt) + tb <- textBufferNew (Just tt) + tv <- textViewNewWithBuffer tf + mk <- textMarkNew Nothing False + it <- textBufferGetIterAtOffset tf (-1) + textBufferAddMark tf mk it + textViewSetEditable tv False + textViewSetWrapMode tv WrapWord + da <- drawingAreaNew + _ <- da `on` exposeEvent $ do + dw <- eventWindow + liftIO $ do + ml <- atomicModifyIORef lRef (\m -> (m, m)) + case ml of + Nothing -> return () + Just l -> do + (ww, hh) <- drawableGetSize dw + renderWithDrawable dw $ do + D.draw (fromIntegral ww) (fromIntegral hh) l + return True + en <- entryNew + entrySetWidthChars en 24 + font <- fontDescriptionFromString "Monospaced 18" + widgetModifyFont tv (Just font) + widgetModifyFont en (Just font) + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAlways + containerAdd sw tv + al <- alignmentNew 1 0 1 1 + set al [ containerChild := da ] + boxPackStart vb en PackNatural 0 + boxPackStart vb sw PackGrow 0 + panedPack1 hb vb False True + panedPack2 hb al True True + set win [ containerChild := hb ] + containerSetFocusChain vb [toWidget en] + let scrollDown = do + textViewScrollToMark tv mk 0 Nothing + addText tag txt = do + start' <- textBufferGetIterAtOffset tb 0 + end' <- textBufferGetIterAtOffset tb (-1) + textBufferDelete tb start' end' + textBufferInsert tb start' (unlines [txt]) + start <- textBufferGetIterAtOffset tb 0 + end <- textBufferGetIterAtOffset tb (-1) + textBufferApplyTag tb tag start end + pos <- textBufferGetIterAtOffset tf (-1) + textBufferInsertRange tf pos start end + textBufferMoveMark tf mk pos + _ <- en `onEntryActivate` do + let exec echo txt = + case interpret txt of + Fail -> addText tagError txt + Skip -> when echo $ do + addText tagInputRem txt + entrySetText en "" + Define def term -> do + when echo $ do + addText tagInputDef txt + entrySetText en "" + atomicModifyIORef envR (\defs -> (M.insert def term defs, ())) + Pure term -> do + when echo $ do + addText tagInputPure txt + entrySetText en "" + mtid <- readIORef evalR + case mtid of + Nothing -> return () + Just tid -> killThread tid + tid <- forkIO $ evaluator 10000 lRef out envR M.empty term goPure + writeIORef evalR (Just tid) + Run term -> do + when echo $ do + addText tagInputRun txt + entrySetText en "" + mtid <- readIORef evalR + case mtid of + Nothing -> return () + Just tid -> killThread tid + tid <- forkIO $ evaluator 10000 lRef out envR M.empty term (goRun (postGUIAsync . addText tagOutput)) + writeIORef evalR (Just tid) + Meta M.Quit -> do + _ <- forkIO $ do + out "quit ;" + postGUISync mainQuit + return () + Meta M.Clear -> do + when echo $ do + addText tagInputMeta txt + entrySetText en "" + atomicModifyIORef envR (\_ -> (M.empty, ())) + Meta M.Browse -> do + when echo $ do + addText tagInputMeta txt + entrySetText en "" + defs <- readIORef envR + addText tagOutputMeta(unwords (M.keys defs)) + Meta (M.Load f) -> do + when echo $ do + addText tagInputMeta txt + f' <- getDataFileName ("lib" f <.> "gu") + s <- (fmap Right (readFile f')) `catchIOError` (return . Left . show) + case s of + Right t -> do + when echo $ do + entrySetText en "" + mapM_ (exec False) (lines t) + Left e -> + addText tagError e + txt <- entryGetText en + exec True txt + scrollDown + _ <- flip timeoutAdd 100 $ widgetQueueDraw da >> return True + widgetShowAll win + mainGUI + +type Go = G.References -> G.Term -> IO (G.Term, G.References) + +goPure :: Go +goPure refs term = return (term, refs) + +goRun :: (String -> IO ()) -> Go +goRun out refs term = do + out (G.pretty term) + return (term, refs) + +gc :: G.References -> G.Term -> (G.Term, G.References) +gc refs term = + let keep = reachable refs term M.empty + (collapse, later) = M.partition (1 ==) keep + in (compact refs term, M.fromList [ (k, compact refs (refs M.! k)) | k <- M.keys collapse ] `M.union` M.fromList [ (k, refs M.! k) | k <- M.keys later ]) + +reachable :: G.References -> G.Term -> Map Integer Integer -> Map Integer Integer +reachable r (G.Lambda _ t) m = reachable r t m +reachable r (G.Apply s t) m = reachable r s (reachable r t m) +reachable r (G.Reference p) m = (if p `M.member` m then id else reachable r (r M.! p)) (M.insertWith (+) p 1 m) +reachable r (G.Trace _ s t) m = reachable r s (reachable r t m) +reachable _ _ m = m + +compact :: G.References -> G.Term -> G.Term +compact r (G.Reference p) = r M.! p +compact _ t = t + +evaluator :: Int -> IORef (Maybe L.Layout) -> (String -> IO ()) -> IORef G.Definitions -> G.References -> G.Term -> Go -> IO () +evaluator tick layout out defsR refs term go = do + defs <- readIORef defsR + let (term1, refs1) = gc refs term + (term0, refs0) <- go refs1 term1 + case G.reduce defs refs0 term0 of + Nothing -> threadDelay tick >> evaluator tick layout out defsR refs0 term0 go + Just (G.Reduced term' refs') -> evaluator tick layout out defsR refs' term' go + Just (G.Rebound _var' term' refs') -> evaluator tick layout out defsR refs' term' go + Just (G.Traced k s term' refs') -> do + atomicModifyIORef layout $ \_ -> (Just $ L.layout term0 refs0, ()) + case k of + "wait" -> case evalNatural (dereference refs0 s) of + Just n -> threadDelay (tick * fromInteger n) + _ -> return () + "noteon" -> case evalList evalNatural (dereference refs0 s) of + Just msg@[_channel, _note, _velocity] -> + out $ "noteon " ++ unwords (map show msg) ++ " ;" + _ -> return () + "noteoff" -> case evalList evalNatural (dereference refs0 s) of + Just msg@[_channel, _note, _velocity] -> + out $ "noteoff " ++ unwords (map show msg) ++ " ;" + _ -> return () + "program" -> case evalList evalNatural (dereference refs0 s) of + Just msg@[_channel, _program] -> + out $ "program " ++ unwords (map show msg) ++ " ;" + _ -> return () + "control" -> case evalList evalNatural (dereference refs0 s) of + Just msg@[_channel, _control, _value] -> + out $ "control " ++ unwords (map show msg) ++ " ;" + _ -> return () + _ -> print (k, G.pretty (dereference refs0 s)) + evaluator tick layout out defsR refs' term' go + +dereference :: G.References -> G.Term -> G.Term +dereference r (G.Reference p) = dereference r (r M.! p) +dereference r (G.Lambda k t) = G.Lambda k (dereference r t) +dereference r (G.Apply a b) = G.Apply (dereference r a) (dereference r b) +dereference r (G.Trace k a b) = G.Trace k (dereference r a) (dereference r b) +dereference _ t = t + +evalNatural :: G.Term -> Maybe Integer +evalNatural (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just 0 +evalNatural (G.Lambda _ (G.Lambda _ (G.Apply (G.Bound 1) t))) = (1 +) `fmap` evalNatural t +evalNatural _ = Nothing + +evalList :: (G.Term -> Maybe a) -> G.Term -> Maybe [a] +evalList _ (G.Lambda _ (G.Lambda _ (G.Bound 0))) = Just [] +evalList f (G.Lambda _ (G.Lambda _ (G.Apply (G.Apply (G.Bound 1) s) t))) = (:) <$> f s <*> evalList f t +evalList _ _ = Nothing + +outputter :: Chan String -> IO () +outputter out = do + hSetBuffering stdout LineBuffering + forever $ do + s <- readChan out + putStrLn s diff --git a/src/Meta.hs b/src/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Meta.hs @@ -0,0 +1,33 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Meta (Meta(..), parse) where + +import Control.Applicative((<|>), (<$), (<*>)) + +import Parse + +data Meta = Quit | Clear | Browse | Load String + deriving (Read, Show, Eq, Ord) + +parse :: Parser String Meta +parse = (Quit <$ sym "quit") + <|> (Clear <$ sym "clear") + <|> (Browse <$ sym "browse") + <|> (Load <$ sym "load" <*> name) diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,143 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Parse where + +import Control.Applicative(Applicative, Alternative, pure, empty, (<|>), (<$>), (<*>), (<*)) + +{- +Strip comments +-------------- + +A comment is everything from '#' to the end of the line. +-} + +decomment :: String -> String +decomment = concatMap (fst . break ('#'==)) . lines + +{- +Tokenize +-------- +-} + +digits :: String +digits = "0123456789" + +lowers :: String +lowers = "abcdefghijklmnopqrstuvwxyz" + +uppers :: String +uppers = "ABCDEFGHIJKLMNOPQRSTUVWXYZ@" + +alpha :: String +alpha = lowers ++ uppers + +alphanum :: String +alphanum = alpha ++ digits + +symbols :: String +symbols = "\\.!?()[],=~:{}" + +spaces :: String +spaces = " " + +{- +Split a string into tokens (each itself a string), such that each token +consists of either all digits, all letters, or a single symbol. Use +whitespace to separate tokens. +-} + +tokenize :: String -> Maybe [String] +tokenize [] = Just [] +tokenize (c:cs) + | c `elem` digits = let (t,ts) = span (`elem` digits) cs + in ((c:t):) <$> tokenize ts + | c `elem` lowers = let (t,ts) = span (`elem` alphanum) cs + in ((c:t):) <$> tokenize ts + | c `elem` symbols = ([c]:) <$> tokenize cs + | c `elem` spaces = tokenize cs + | otherwise = Nothing + +{- +Parsing primitives +------------------ + +A parser takes a list of tokens to a list of possible partial parses. +-} + +newtype Parser s t = P{ unP :: [s] -> [(t, [s])] } + +instance Functor (Parser s) where + fmap f (P p) = P (\q -> [ (f v, s) | (v,s) <- p q ] ) + +instance Applicative (Parser s) where + pure f = P (\q -> [(f, q)]) + P p1 <*> P p2 = P (\q -> [ (u v, t) | (u, s) <- p1 q, (v, t) <- p2 s ]) + +instance Alternative (Parser s) where + empty = P (\_ -> []) + P p1 <|> P p2 = P (\q -> p1 q ++ p2 q) + +{- +Accept a token that satisfies a predicate. +-} + +satisfy :: (s -> Bool) -> Parser s s +satisfy p = P (\q -> case q of + (x:xs) | p x -> [(x,xs)] + _ -> []) + +{- +Accept a specific token. +-} + +sym :: Eq s => s -> Parser s s +sym a = satisfy (== a) + +{- +Accept some p's separated by s's. +-} + +someSep :: Parser s a -> Parser s t -> Parser s [t] +someSep s p = ((:[]) <$> p) <|> ((:) <$> p <* s <*> someSep s p) + +{- +Accept some p's separated by s's, or nothing. +-} + +manySep :: Parser s a -> Parser s t -> Parser s [t] +manySep s p = pure [] <|> someSep s p + +{- +Accept a name consisting of letters. +-} + +name :: Parser String String +name = P (\q -> case q of + (p@(r:_):ps) | r `elem` lowers -> [(p, ps)] + _ -> []) + +{- +Accept an integer consisting of digits. +-} + +integer :: Parser String Integer +integer = P (\q -> case q of + (p:ps) | all (`elem` digits) p -> [(read p, ps)] + _ -> []) diff --git a/src/Sugar.hs b/src/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Sugar.hs @@ -0,0 +1,124 @@ +{- + gulcii -- graphical untyped lambda calculus interpreter + Copyright (C) 2011, 2013 Claude Heiland-Allen + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +{- + +Sugared term parser +=================== + +Grammar +------- + +T ::= v | '\\' v+ ('.' | '!' | '?') T | T+ | '(' T ')' | n | '[' (T (, T)*)? ']' | '{' v ':' T '}' T + +-} + +module Sugar(Term(..), parse, desugar) where + +import Control.Applicative(Applicative, Alternative, (<|>), (<$>), (<$), (<*>), (<*), some, liftA2) +import Data.List ((\\)) + +import Parse +import qualified Lambda as U +import Evaluation (Strategy(..)) + +data Term + = Variable String + | Lambda Strategy [String] Term + | Apply [Term] + | Group Term + | Natural Integer + | List [Term] + | Trace String Term Term + deriving (Read, Show, Eq, Ord) + +parse :: Parser String Term +parse = Apply <$> some parse' + +parse' :: Parser String Term +parse' = (flip Lambda <$ sym "\\" <*> some name <*> strategy <*> parse) + <|> (Group <$ sym "(" <*> parse <* sym ")") + <|> (Variable <$> name) + <|> (Natural <$> integer) + <|> (List <$ sym "[" <*> manySep (sym ",") parse <* sym "]") + <|> (Trace <$ sym "{" <*> name <* sym ":" <*> parse <* sym "}" <*> parse) + +strategy :: Parser String Strategy +strategy = (Strict <$ sym "!") <|> (Lazy <$ sym ".") <|> (Copy <$ sym "?") + +{- +A list of all possible legal variable names, need to generate fresh +variables (ie, names guaranteed to be unused in a given term). +-} + +variables :: [String] +variables = [ v:vs | vs <- [] : variables, v <- ['a'..'z'] ] + +{- +Desugar according to the following conventions: + + Outermost parentheses are dropped: + M N means of (M N) + + Applications are left associative: + M N P means (M N) P + + The body of an abstraction extends as far right as possible + \x.M N means \x.(M N) and not (\x.M) N + + A sequence of abstractions are contracted: + \x.\y.\z.N is abbreviated as \x y z.N + +Desugar naturals with their Scott-encoding: + + 0 -> \s z . z + (1+n) -> \s z . s (desugar n) + +Desugar lists with their Scott-encoding: + + [] -> \ c n . n + (x:xs) -> \ c n . c (desugar x) (desugar xs) +-} + +desugar :: Term -> Maybe U.Term +desugar (Variable v) = Just $ U.Variable v +desugar (Lambda _ [] _) = Nothing +desugar (Lambda k [v] t) = fmap (U.Lambda k v) $ desugar t +desugar (Lambda k (v:vs) t) = fmap (U.Lambda k v) $ desugar (Lambda k vs t) +desugar (Apply []) = Nothing +desugar (Apply ts) = foldl1 (liftA2 U.Apply) (map desugar ts) +desugar (Group t) = desugar t +desugar (Natural 0) = Just $ lam "s" (lam "z" (U.Variable "z")) +desugar (Natural n) = + let Just nn = desugar (Natural (n - 1)) + (s:z:_) = variables \\ U.freeVariablesIn nn + in Just $ lam s (lam z (U.Apply (U.Variable s) nn)) +desugar (List []) = Just $ lam "c" (lam "n" (U.Variable "n")) +desugar (List (l:ls)) = + let t = desugar l + ts = desugar (List ls) + in case (t,ts) of + (Just t', Just ts') -> + let (c:n:_) = (variables \\ U.freeVariablesIn t') \\ U.freeVariablesIn ts' + in Just $ lam c (lam n (U.Apply (U.Apply (U.Variable c) t') ts')) + _ -> Nothing +desugar (Trace k s t) = U.Trace k <$> desugar s <*> desugar t + +lam :: String -> U.Term -> U.Term +lam = U.Lambda Lazy