diff --git a/CHANGELOG.org b/CHANGELOG.org index 30bfd142c..9de302812 100644 --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -1,4 +1,29 @@ - +* 0.3.1 +** Bug Fixes +- Lambda to geb should now work, we fixed a bug with how case was + translated, and created some tests +* 0.3.0 +** User Facing Changes +- _Lambda Changes_ + 1. Types are no longer required on all terms + 2. Application and Lambda now take multiple arguments, and expect + arguments uncurried +- _Core Category Changes_ + + Opaque types now extend the core category +- An interpreter now can be used from any category of the codebase +- Cleaner Code generation, through the new BITC backend. +** Bug Fixes +- Geb to Poly had a few bugs fixed in injection, and pair + representations +- Geb no longer exhausts the stack when trying to generate out + vampir for basic circuits. +** Internal Changes +- Reference extensions allow factoring out common parts, not used + outside of poly. +- _We now have the following generic modules_ + 1. =GEB.GENERICS= - which hosts all generic transformations + 2. =GEB.EXTENSION= - which holds all extensions +- We have streamlined the package loading order. * 0.2.0 - Change the graphing from a box and line diagram, to a proper graph diagram. + We now utilize clim-dot to draw the graph. diff --git a/README b/README index ed801e716..d08cd935e 100644 --- a/README +++ b/README @@ -5,12 +5,18 @@ Welcome to the GEB project. ## Links + + Here is the [official repository](https://github.com/anoma/geb/) and [HTML documentation](https://anoma.github.io/geb/) for the latest version. + + ### code coverage + + For test coverage it can be found at the following links: [SBCL test coverage](./tests/cover-index.html) @@ -28,6 +34,8 @@ I recommend reading the CCL code coverage version, as it has proper tags. Currently they are manually generated, and thus for a more accurate assessment see GEB-TEST:CODE-COVERAGE + + ## Getting Started Welcome to the GEB Project! @@ -104,13 +112,13 @@ to use An example use of this binary is as follows ```bash -mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.spec::*entry*" -l -v -o "foo.pir" +mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.main::*entry*" -l -v -o "foo.pir" mariari@Gensokyo % cat foo.pir -def *entry* x { - 0 -}% -mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.spec::*entry*" -l -v +def entry x1 = { + (x1) +};% +mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.main::*entry*" -l -v def *entry* x { 0 } @@ -128,11 +136,18 @@ def *entry* x { starting from a file *foo.lisp* that has +any valid lambda form. Good examples can be found at the following section: + +GEB.LAMBDA:@STLC + +with the term bound to some global variable + ```lisp -(in-package :geb.lambda.spec) +(in-package :geb.lambda.main) (defparameter *entry* - (typed unit geb:so1)) + (lamb (list (coprod so1 so1)) + (index 0))) ``` inside of it. @@ -276,6 +291,8 @@ conjectures about GEB ## Categorical Model + + Geb is organizing programming language concepts (and entities!) using [category theory](https://plato.stanford.edu/entries/category-theory/), originally developed by mathematicians, @@ -343,31 +360,31 @@ In particular, we shall rely on the following universal constructions: -1. The construction of binary products $A × B$ of sets $A,B$, and the empty product $\mathsf{1}$. +1. The construction of binary products $A × B$ of sets $A,B$, and the empty product $mathsf{1}$. 2. The construction of “function spaces” $B^A$ of sets $A,B$, called *exponentials*, i.e., collections of functions between pairs of sets. 3. The so-called [*currying*](https://en.wikipedia.org/wiki/Currying) of functions, - $C^{(B^A)} \cong C^{(A × B)}$, + $C^{(B^A)} cong C^{(A × B)}$, such that providing several arguments to a function can done either simultaneously, or in sequence. 4. The construction of sums (a.k.a. co-products) $A + B$ of sets $A,B$, corresponding to forming disjoint unions of sets; - the empty sum is $\varnothing$. + the empty sum is $varnothing$. Product, sums and exponentials are the (almost) complete tool chest for writing polynomial expressions, e.g., -$$Ax^{\sf 2} +x^{\sf 1} - Dx^{\sf 0}.$$ +$$Ax^{sf 2} +x^{sf 1} - Dx^{sf 0}.$$ (We need these later to define [“algebraic data types”](https://en.wikipedia.org/wiki/Polynomial_functor_(type_theory)).) In the above expression, we have sets instead of numbers/constants -where $ \mathsf{2} = \lbrace 1, 2 \rbrace$, -$ \mathsf{1} = \lbrace 1 \rbrace$, -$ \mathsf{0} = \lbrace \rbrace = \varnothing$, +where $ mathsf{2} = lbrace 1, 2 rbrace$, +$ mathsf{1} = lbrace 1 rbrace$, +$ mathsf{0} = lbrace rbrace = varnothing$, and $A$ and $B$ are arbitrary (finite) sets. We are only missing a counterpart for the *variable*! Raising an arbitrary set to “the power” of a constant set @@ -390,6 +407,8 @@ Benjamin Pierce's as it is very amenable *and* covers the background we need in 60 short pages. + + ### Morphisms @@ -531,7 +550,7 @@ In this piece of code we can notice a few things: 4. We can write further methods extending the function to other subtypes. -Thus the GEB:TO-POLY function is written in such a way that it +Thus the GEB.COMMON:TO-POLY function is written in such a way that it supports a closed definition and open extensions, with GEB.UTILS:SUBCLASS-RESPONSIBILITY serving to be called if an extension a user wrote has no handling of this method. @@ -599,6 +618,72 @@ contained in various data structures Use GEB.MAIN:CURRY instead. +### Geneircs + +###### \[in package GEB.GENERICS\] +These functions represent the generic functions that can be run on +many parts of the compiler, they are typically rexported on any +package that implements the given generic function. + +You can view their documentation in their respective API sections. + +The main documentation for the functionality is given here, with +examples often given in the specific methods + +- [generic-function] GAPPLY MORPHISM OBJECT + + Applies a given Moprhism to a given object. + + This is practically a naive interpreter for any category found + throughout the codebase. + + Some example usages of GAPPLY are. + + ```lisp + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (left so1)) + (right s-1) + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (right so1)) + (left s-1) + ``` + + +- [generic-function] TO-CIRCUIT MORPHISM NAME + + Turns a MORPHISM into a Vampir circuit. the NAME is the given name of + the output circuit. + +- [generic-function] TO-BITC MORPHISM + + Turns a given MORPHISM into a GEB.BITC.SPEC:BITC + +- [generic-function] TO-POLY MORPHISM + + Turns a given MORPHISM into a GEB.POLY.SPEC:POLY + +- [generic-function] TO-CAT CONTEXT TERM + + Turns a MORPHISM with a context into Geb's Core category + +- [generic-function] TO-VAMPIR MORPHISM VALUES CONSTRAINTS + + Turns a MORPHISM into a Vampir circuit, with concrete values. + + The more natural interface is TO-CIRCUIT, however this is a more low + level interface into what the polynomial categories actually + implement, and thus can be extended or changed. + + The VALUES are likely vampir values in a list. + + The CONSTRAINTS represent constraints that get creating + ### Core Category ###### \[in package GEB.SPEC\] @@ -624,7 +709,7 @@ to the GEB-DOCS/DOCS:@OPEN-TYPE that allows for user extension. - [type] SUBSTOBJ -- [type] +- [class] \ DIRECT-POINTWISE-MIXIN META-MIXIN CAT-OBJ the class corresponding to SUBSTOBJ. See GEB-DOCS/DOCS:@OPEN-CLOSED @@ -640,7 +725,7 @@ type substobj = so0 ``` -- [type] PROD +- [class] PROD \ The PRODUCT object. Takes two CAT-OBJ values that get put into a pair. @@ -662,7 +747,7 @@ type substobj = so0 Here we create a product of two GEB-BOOL:BOOL types. -- [type] COPROD +- [class] COPROD \ the CO-PRODUCT object. Takes CAT-OBJ values that get put into a choice of either value. @@ -685,7 +770,7 @@ type substobj = so0 Here we create the boolean type, having a choice between two unit values. -- [type] SO0 +- [class] SO0 \ The Initial Object. This is sometimes known as the [VOID](https://en.wikipedia.org/wiki/Void_type) type. @@ -703,7 +788,7 @@ type substobj = so0 `lisp ` -- [type] SO1 +- [class] SO1 \ The Terminal Object. This is sometimes referred to as the [Unit](https://en.wikipedia.org/wiki/Unit_type) type. @@ -756,7 +841,7 @@ to the GEB-DOCS/DOCS:@OPEN-TYPE that allows for user extension. The morphisms of the SUBSTMORPH category -- [type] +- [class] DIRECT-POINTWISE-MIXIN META-MIXIN CAT-MORPH the class type corresponding to SUBSTMORPH. See GEB-DOCS/DOCS:@OPEN-CLOSED @@ -783,7 +868,7 @@ morphism to the layout specified by the given SUBSTOBJ. Thus we can view this as automatically lifting a SUBSTOBJ into a SUBSTMORPH -- [type] COMP +- [class] COMP \ The composition morphism. Takes two CAT-MORPH values that get applied in standard composition order. @@ -829,7 +914,7 @@ SUBSTMORPH ``` -- [type] CASE +- [class] CASE \ Eliminates coproducts. Namely Takes two CAT-MORPH values, one gets applied on the left coproduct while the other gets applied on the @@ -860,7 +945,7 @@ SUBSTMORPH MCASE to denote a morphism saying. IF the input is of the shape SO1, then give us True, otherwise flip the value of the boolean coming in. -- [type] INIT +- [class] INIT \ The INITIAL Morphism, takes any CAT-OBJ and creates a moprhism from SO0 (also known as void) to the object given. @@ -883,7 +968,7 @@ SUBSTMORPH In this example we are creating a unit value out of void. -- [type] TERMINAL +- [class] TERMINAL \ The TERMINAL morphism, Takes any CAT-OBJ and creates a morphism from that object to SO1 (also known as unit). @@ -919,7 +1004,7 @@ SUBSTMORPH The fourth example is taking a GEB-BOOL:BOOL and returning GEB-BOOL:TRUE. -- [type] PAIR +- [class] PAIR \ Introduces products. Namely Takes two CAT-MORPH values. When the PAIR morphism is applied on data, these two CAT-MORPH's are @@ -948,11 +1033,11 @@ SUBSTMORPH projects back the left field SO1 as the first value of the pair and projects back the GEB-BOOL:BOOL field as the second values. -- [type] DISTRIBUTE +- [class] DISTRIBUTE \ The distributive law -- [type] INJECT-LEFT +- [class] INJECT-LEFT \ The left injection morphism. Takes two CAT-OBJ values. It is the dual of INJECT-RIGHT @@ -984,7 +1069,7 @@ SUBSTMORPH morphism saying. `IF` the input is of the shape SO1, then give us True, otherwise flip the value of the boolean coming in. -- [type] INJECT-RIGHT +- [class] INJECT-RIGHT \ The right injection morphism. Takes two CAT-OBJ values. It is the dual of INJECT-LEFT @@ -1016,7 +1101,7 @@ SUBSTMORPH MCASE to denote a morphism saying. IF the input is of the shape SO1, then give us True, otherwise flip the value of the boolean coming in. -- [type] PROJECT-LEFT +- [class] PROJECT-LEFT \ The LEFT PROJECTION. Takes two CAT-MORPH values. When the LEFT PROJECTION morphism is then applied, it grabs the left value of a product, @@ -1044,7 +1129,7 @@ SUBSTMORPH (GEB-BOOL:BOOL × SO1 × GEB-BOOL:BOOL) -- [type] PROJECT-RIGHT +- [class] PROJECT-RIGHT \ The RIGHT PROJECTION. Takes two CAT-MORPH values. When the RIGHT PROJECTION morphism is then applied, it grabs the right value of a product, @@ -1073,7 +1158,7 @@ SUBSTMORPH (GEB-BOOL:BOOL × SO1 × GEB-BOOL:BOOL) -- [type] FUNCTOR +- [class] FUNCTOR \ The @GEB-ACCESSORS specific to @GEB-SUBSTMORPH @@ -1129,6 +1214,47 @@ The @GEB-ACCESSORS specific to @GEB-SUBSTMORPH Right projection (product elimination) +#### Realized Subst Objs + +This section covers the REALIZED-OBJECT type. This +represents a realized SUBSTOBJ term. + +The REALIZED-OBJECT is not a real constructor but rather a sum +type for the following type + +```lisp +(deftype realized-object () `(or left right list so1 so0)) +``` + +In ML we would have written something like + +```haskell +type realized-object = so0 + | so1 + | list + | left + | right +``` + + +- [type] REALIZED-OBJECT + + A realized object that can be sent into. + + Lists represent PROD in the category + + LEFT and RIGHT represents realized values for COPROD + + Lastly SO1 and SO0 represent the proper class + +- [class] LEFT DIRECT-POINTWISE-MIXIN + +- [class] RIGHT DIRECT-POINTWISE-MIXIN + +- [function] LEFT OBJ + +- [function] RIGHT OBJ + ### Accessors ###### \[in package GEB.UTILS\] @@ -1188,6 +1314,11 @@ likely to be used. They may even augment existing classes. the then branch of the [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) +- [generic-function] CODE OBJ + + the code of the + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + ### Constructors ###### \[in package GEB.SPEC\] @@ -1238,6 +1369,68 @@ More Ergonomic API variants for *SO0* and *SO1* Various forms and structures built on-top of @GEB-CATEGORIES +- [method] GAPPLY (MORPH \) OBJECT + + My main documentation can be found on GAPPLY + + I am the GAPPLY for , the + OBJECT that I expect is of type REALIZED-OBJECT. See the + documentation for REALIZED-OBJECT for the forms it can take. + + Some examples of me are + + ```lisp + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (left so1)) + (right s-1) + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (right so1)) + (left s-1) + GEB> (gapply geb-bool:and + (list (right so1) + (right so1))) + (right s-1) + GEB> (gapply geb-bool:and + (list (left so1) + (right so1))) + (left s-1) + GEB> (gapply geb-bool:and + (list (right so1) + (left so1))) + (left s-1) + GEB> (gapply geb-bool:and + (list (left so1) + (left so1))) + (left s-1) + ``` + + +- [method] GAPPLY (MORPH OPAQUE-MORPH) OBJECT + + My main documentation can be found on GAPPLY + + I am the GAPPLY for a generic OPAQUE-MOPRH + I simply dispatch GAPPLY on my interior code + `lisp + GEB> (gapply (comp geb-list:*car* geb-list:*cons*) + (list (right geb-bool:true-obj) (left geb-list:*nil*))) + (right GEB-BOOL:TRUE) + ` + +- [method] GAPPLY (MORPH OPAQUE) OBJECT + + My main documentation can be found on GAPPLY + + I am the GAPPLY for a generic OPAQUE I + simply dispatch GAPPLY on my interior code, which + is likely just an object + #### Booleans ###### \[in package GEB-BOOL\] @@ -1290,20 +1483,68 @@ The functions given work on this. - [symbol-macro] OR +#### Lists + +###### \[in package GEB-LIST\] +Here we define out the idea of a List. It comes naturally from the +concept of coproducts. Since we lack polymorphism this list is +concrete over [GEB-BOOL:@GEB-BOOL][section] In ML syntax it looks like + +```haskell +data List = Nil | Cons Bool List +``` + +We likewise define it with coproducts, with the recursive type being opaque + +```lisp +(defparameter *nil* (so1)) + +(defparameter *cons-type* (reference 'cons)) + +(defparameter *canonical-cons-type* + (opaque 'cons + (prod geb-bool:bool *cons-type*))) + +(defparameter *list* + (coprod *nil* *cons-type*)) +``` + +The functions given work on this. + +- [variable] *NIL* NIL + +- [variable] *CONS-TYPE* CONS + +- [variable] *LIST* LIST + +- [variable] *CAR* CAR + +- [variable] *CONS* CONS-Μ + +- [variable] *CDR* CDR + +- [symbol-macro] CONS->LIST + +- [symbol-macro] NIL->LIST + +- [variable] *CANONICAL-CONS-TYPE* CONS + #### Translation Functions ###### \[in package GEB.TRANS\] These cover various conversions from @GEB-SUBSTMORPH and @GEB-SUBSTMU into other categorical data structures. -- [generic-function] TO-POLY MORPHISM +- [method] TO-POLY (OBJ \) - Turns a @GEB-SUBSTMORPH into a POLY:POLY +- [method] TO-POLY (OBJ \) -- [function] TO-CIRCUIT OBJ NAME +- [method] TO-CIRCUIT (OBJ \) NAME Turns a @GEB-SUBSTMORPH to a Vamp-IR Term +- [method] TO-BITC (OBJ \) + #### Utility ###### \[in package GEB.MAIN\] @@ -1341,7 +1582,7 @@ Various utility functions ontop of @GEB-CATEGORIES (const f x) : a → b ``` - Further, If the input `F` is an ALIAS, then we wrap the output + Further, If the input `F` has an ALIAS, then we wrap the output in a new alias to denote it's a constant version of that value. Example: @@ -1406,6 +1647,23 @@ Various utility functions ontop of @GEB-CATEGORIES In category terms, `a → c^b` is isomorphic to `a → b → c` +- [function] COPROD-MOR F G + + Given f : A → B and g : C → D gives appropriate morphism between + COPROD objects f x g : A + B → C + D via the unversal property. + That is, the morphism part of the coproduct functor Geb x Geb → Geb + +- [function] PROD-MOR F G + + Given f : A → B and g : C → D gives appropriate morphism between + PROD objects f x g : A x B → C x D via the unversal property. + This is the morphism part of the product functor Geb x Geb → Geb + +- [function] UNCURRY Y Z F + + Given a morphism f : x → z^y and explicitly given y and z variables + produces an uncurried version f' : x × y → z of said morphism + - [generic-function] TEXT-NAME MORPH Gets the name of the moprhism @@ -1428,6 +1686,73 @@ with GEB: ``` +## Extension Sets for Categories + +###### \[in package GEB.EXTENSION.SPEC\] +This package contains many extensions one may see over the codebase. + +Each extension adds an unique feature to the categories they are +extending. To learn more, read about the individual extension you are +interested in. + +Common Sub expressions represent repeat logic that can be found +throughout any piece of code + +- [class] COMMON-SUB-EXPRESSION DIRECT-POINTWISE-MIXIN META-MIXIN CAT-MORPH + + I represent common sub-expressions found throughout the code. + + I implement a few categorical extensions. I am a valid + CAT-MORPH along with fulling the interface for the + GEB.POLY.SPEC: category. + + The name should come from an algorithm that automatically fines common + sub-expressions and places the appropriate names. + +- [function] MAKE-COMMON-SUB-EXPRESSION &KEY OBJ NAME + +The Opaque extension lets users write categorical objects and +morphisms where their implementation hide the specifics of what +types they are operating over + +- [class] OPAQUE CAT-OBJ META-MIXIN + + I represent an object where we want to hide the implementation + details of what kind of GEB:SUBSTOBJ I am. + +- [class] REFERENCE CAT-OBJ CAT-MORPH DIRECT-POINTWISE-MIXIN META-MIXIN + + I represent a reference to an OPAQUE identifier. + +- [class] OPAQUE-MORPH CAT-MORPH META-MIXIN + + This represents a morphsim where we want to deal with an + OPAQUE that we know intimate details of + +- [method] CODE (OPAQUE-MORPH OPAQUE-MORPH) + + the code that represents the underlying morphsism + +- [method] DOM (OPAQUE-MORPH OPAQUE-MORPH) + + The dom of the opaque morph + +- [method] CODOM (OPAQUE-MORPH OPAQUE-MORPH) + + The codom of the opaque morph + +- [method] CODE (OPAQUE OPAQUE) + +- [method] NAME (OPAQUE OPAQUE) + +- [method] NAME (REFERENCE REFERENCE) + +- [function] REFERENCE NAME + +- [function] OPAQUE-MORPH CODE &KEY (DOM (DOM CODE)) (CODOM (CODOM CODE)) + +- [function] OPAQUE NAME CODE + ## The GEB GUI ###### \[in package GEB-GUI\] @@ -1455,7 +1780,7 @@ layout of the term, showing what kind of data #### Aiding the Visualizer One can aid the visualization process a bit, this can be done by -simply playing GEB:ALIAS around the object, this will place it +simply placing ALIAS around the object, this will place it in a box with a name to better identify it in the graphing procedure. ### The GEB Graphizer @@ -1521,6 +1846,12 @@ The core types that facilittate the functionality particular node. This information is tracked, by storing the object that goes to it in the meta table and recovering the note. +- [class] NODE-NOTE + +- [class] SQUASH-NOTE + + This note should be squashed into another note and or node. + - [function] MAKE-NOTE &REST INITARGS &KEY FROM NOTE VALUE &ALLOW-OTHER-KEYS - [function] MAKE-SQUASH &REST INITARGS &KEY VALUE &ALLOW-OTHER-KEYS @@ -1589,224 +1920,1149 @@ ways that are intuitive to the user These simplifications should not change the semantics of the graph, only display it in a more bearable way -## Polynomial Specification +## Bits (Boolean Circuit) Specification -###### \[in package GEB.POLY\] -This covers a GEB view of Polynomials. In particular this type will -be used in translating GEB's view of Polynomials into Vampir +###### \[in package GEB.BITC\] +This covers a GEB view of Boolean Circuits. In particular this type will +be used in translating GEB's view of Boolean Circuits into Vampir -### Polynomial Types +### Bits Types -###### \[in package GEB.POLY.SPEC\] -This section covers the types of things one can find in the POLY +###### \[in package GEB.BITC.SPEC\] +This section covers the types of things one can find in the BITS constructors -- [type] POLY - -- [type] - -- [type] IDENT - - The Identity Element - -- [type] + +- [type] BITC -- [type] * +- [class] DIRECT-POINTWISE-MIXIN CAT-MORPH -- [type] / +- [class] COMPOSE \ -- [type] - + composes the MCAR and the MCADR -- [type] MOD +- [class] FORK \ -- [type] COMPOSE + Copies the MCAR of length n onto length 2\*n by copying its + inputs (MCAR). -- [type] IF-ZERO +- [class] PARALLEL \ - compare with zero: equal takes first branch; - not-equal takes second branch + ```lisp + (parallel x y) + ``` + + constructs a PARALLEL term where the MCAR is `x` and the + MCADR is `y`, + + where if + + ``` + x : a → b, y : c → d + ------------------------------- + (parallel x y) : a + c → b + d + ``` + + then the PARALLEL will return a function from a and c to b + and d where the MCAR and MCADR run on subvectors of the input. -- [type] IF-LT +- [class] SWAP \ - If the MCAR argument is strictly less than the MCADR then the - THEN branch is taken, otherwise the ELSE branch is taken. + ```lisp + (swap n m) + ``` + + binds the MCAR to n and MCADR to m, where if the input + vector is of length `n + m`, then it swaps the bits, algebraically we + view it as + + ```lisp + (swap n m) : #*b₁...bₙbₙ₊₁...bₙ₊ₘ → #*bₙ₊₁...bₘ₊ₙb₁...bₙ + ``` -### Polynomial Constructors -###### \[in package GEB.POLY.SPEC\] -Every accessor for each of the CLASS's found here are from @GEB-ACCESSORS +- [class] ONE \ -- [symbol-macro] IDENT + ONE represents the map from 0 onto 1 producing a vector + with only 1 in it. -- [function] + MCAR MCADR &REST ARGS +- [class] ZERO \ - Creates a multiway constructor for + + ZERO map from 0 onto 1 producing a vector with only 0 in + it. -- [function] * MCAR MCADR &REST ARGS +- [class] IDENT \ - Creates a multiway constructor for \* + IDENT represents the identity -- [function] / MCAR MCADR &REST ARGS +- [class] DROP \ - Creates a multiway constructor for / + DROP represents the unique morphism from n to 0. -- [function] - MCAR MCADR &REST ARGS +- [class] BRANCH \ - Creates a multiway constructor for - + ```lisp + (branch x y) + ``` + + constructs a BRANCH term where the MCAR is `x` and the + MCADR is `y`, + + where if + + ``` + x : a → b, y : a → b + ------------------------------- + (branch x y) : 1+a → b + ``` + + then the BRANCH will return a function on the type `1 + a`, where the + 1 represents a bit to branch on. If the first bit is `0`, then the + MCAR is ran, however if the bit is `1`, then the MCADR is ran. -- [function] MOD MCAR MCADR +### Bits (Boolean Circuit) Constructors - MOD ARG1 by ARG2 +###### \[in package GEB.BITC.SPEC\] +Every accessor for each of the CLASS's found here are from @GEB-ACCESSORS - [function] COMPOSE MCAR MCADR &REST ARGS Creates a multiway constructor for COMPOSE -- [function] IF-ZERO PRED THEN ELSE +- [function] FORK MCAR - checks if PREDICATE is zero then take the THEN branch otherwise the ELSE branch + FORK ARG1 -- [function] IF-LT MCAR MCADR THEN ELSE +- [function] PARALLEL MCAR MCADR &REST ARGS - Checks if the MCAR is less than the MCADR and chooses the appropriate branch + Creates a multiway constructor for PARALLEL -### Polynomial Transformations +- [function] SWAP MCAR MCADR -###### \[in package GEB.POLY.TRANS\] -This covers transformation functions from + swap ARG1 and ARG2 -- [generic-function] TO-VAMPIR MORPHISM VALUE +- [symbol-macro] ONE - Turns a POLY term into a Vamp-IR term with a given value +- [symbol-macro] ZERO -- [function] TO-CIRCUIT MORPHISM NAME +- [function] IDENT MCAR - Turns a POLY term into a Vamp-IR Gate with the given name + ident ARG1 -## The Simply Typed Lambda Calculus model +- [function] DROP MCAR -###### \[in package GEB.LAMBDA\] -This covers GEB's view on simply typed lambda calculus + drop ARG1 -### Lambda Specification +- [function] BRANCH MCAR MCADR -###### \[in package GEB.LAMBDA.SPEC\] -This covers the various the abstract data type that is the simply - typed lambda calculus within GEB. + branch with ARG1 or ARG2 -The specification follows from the sum type declaration +### Bits (Boolean Circuit) API -```lisp -(defunion stlc - (absurd (value t)) - unit - (left (value t)) - (right (value t)) - (case-on (lty geb.spec:substmorph) - (rty geb.spec:substmorph) - (cod geb.spec:substmorph) - (on t) (left t) (right t)) - (pair (lty geb.spec:substmorph) (rty geb.spec:substmorph) (left t) (right t)) - (fst (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (snd (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (lamb (vty geb.spec:substmorph) (tty geb.spec:substmorph) (value t)) - (app (dom geb.spec:substmorph) (cod geb.spec:substmorph) (func t) (obj t)) - (index (index fixnum))) -``` +###### \[in package GEB.BITC.MAIN\] +This covers the Bits (Boolean Circuit) API +- [method] GAPPLY (MORPHISM \) (OBJECT BIT-VECTOR) -- [type] + My My main documentation can be found on GAPPLY + + I am the GAPPLY for , the + OBJECT that I expect is of type NUMBER. GAPPLY + reduces down to ordinary common lisp expressions rather straight + forwardly + + ```lisp + ;; figure out the number of bits the function takes + GEB-TEST> (dom (to-bitc geb-bool:and)) + 2 (2 bits, #x2, #o2, #b10) + GEB-TEST> (gapply (to-bitc geb-bool:and) #*11) + #*1 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*10) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*01) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*00) + #*0 + ``` -- [type] STLC -- [type] ABSURD +- [method] GAPPLY (MORPHISM \) (OBJECT LIST) -- [function] ABSURD-VALUE INSTANCE + I am a helper gapply function, where the second argument for + is a list. See the docs for the BIT-VECTOR version for + the proper one. We do allow sending in a list like so + + ```lisp + ;; figure out the number of bits the function takes + GEB-TEST> (dom (to-bitc geb-bool:and)) + 2 (2 bits, #x2, #o2, #b10) + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 1)) + #*1 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 0)) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 1)) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 0)) + #*0 + ``` -- [type] UNIT -- [type] PAIR +- [method] DOM (X \) -- [function] PAIR-LTY INSTANCE + Gives the length of the bit vector the moprhism takes -- [function] PAIR-RTY INSTANCE +- [method] CODOM (X \) -- [function] PAIR-LEFT INSTANCE + Gives the length of the bit vector the morphism returns -- [function] PAIR-RIGHT INSTANCE +### Bits (Boolean Circuit) Transformations -- [type] LEFT +###### \[in package GEB.BITC.TRANS\] +This covers transformation functions from -- [function] LEFT-VALUE INSTANCE +- [method] TO-CIRCUIT (MORPHISM \) NAME -- [type] RIGHT + Turns a BITC term into a Vamp-IR Gate with the given name -- [function] RIGHT-VALUE INSTANCE +- [method] TO-VAMPIR (OBJ COMPOSE) VALUES CONSTRAINTS -- [type] CASE-ON +- [method] TO-VAMPIR (OBJ FORK) VALUES CONSTRAINTS -- [function] CASE-ON-LTY INSTANCE + Copy input n intput bits into 2\*n output bits -- [function] CASE-ON-RTY INSTANCE +- [method] TO-VAMPIR (OBJ PARALLEL) VALUES CONSTRAINTS -- [function] CASE-ON-COD INSTANCE + Take n + m bits, execute car the n bits and cadr on the m bits and + concat the results from car and cadr -- [function] CASE-ON-ON INSTANCE +- [method] TO-VAMPIR (OBJ SWAP) VALUES CONSTRAINTS -- [function] CASE-ON-LEFT INSTANCE + Turn n + m bits into m + n bits by swapping -- [function] CASE-ON-RIGHT INSTANCE +- [method] TO-VAMPIR (OBJ ONE) VALUES CONSTRAINTS -- [type] FST + Produce a bitvector of length 1 containing 1 -- [function] FST-LTY INSTANCE +- [method] TO-VAMPIR (OBJ ZERO) VALUES CONSTRAINTS -- [function] FST-RTY INSTANCE + Produce a bitvector of length 1 containing 0 -- [function] FST-VALUE INSTANCE +- [method] TO-VAMPIR (OBJ IDENT) VALUES CONSTRAINTS -- [type] SND + turn n bits into n bits by doing nothing -- [function] SND-LTY INSTANCE +- [method] TO-VAMPIR (OBJ DROP) VALUES CONSTRAINTS -- [function] SND-RTY INSTANCE + turn n bits into an empty bitvector -- [function] SND-VALUE INSTANCE +- [method] TO-VAMPIR (OBJ BRANCH) VALUES CONSTRAINTS -- [type] LAMB + Look at the first bit. + + If its 0, run f on the remaining bits. + + If its 1, run g on the remaining bits. -- [function] LAMB-VTY INSTANCE +## Polynomial Specification -- [function] LAMB-TTY INSTANCE +###### \[in package GEB.POLY\] +This covers a GEB view of Polynomials. In particular this type will +be used in translating GEB's view of Polynomials into Vampir -- [function] LAMB-VALUE INSTANCE +### Polynomial Types -- [type] APP +###### \[in package GEB.POLY.SPEC\] +This section covers the types of things one can find in the POLY +constructors -- [function] APP-DOM INSTANCE +- [type] POLY -- [function] APP-COD INSTANCE +- [class] DIRECT-POINTWISE-MIXIN -- [function] APP-FUNC INSTANCE +- [type] IDENT -- [function] APP-OBJ INSTANCE + The Identity Element -- [type] INDEX +- [type] + -- [function] INDEX-INDEX INSTANCE +- [type] * -- [function] TYPED V TYP +- [type] / - Puts together the type declaration with the value itself for lambda terms +- [type] - -- [function] TYPED-STLC-TYPE INSTANCE +- [type] MOD -- [function] TYPED-STLC-VALUE INSTANCE +- [type] COMPOSE -### Main functionality +- [type] IF-ZERO -###### \[in package GEB.LAMBDA.MAIN\] -This covers the main API for the STLC module + compare with zero: equal takes first branch; + not-equal takes second branch + +- [type] IF-LT + + If the MCAR argument is strictly less than the MCADR then the + THEN branch is taken, otherwise the ELSE branch is taken. + +### Polynomial API + +###### \[in package GEB.POLY.MAIN\] +This covers the polynomial API + +- [method] GAPPLY (MORPHISM \) OBJECT + + My main documentation can be found on GAPPLY + + I am the GAPPLY for POLY:, the + OBJECT that I expect is of type NUMBER. GAPPLY reduces down to + ordinary common lisp expressions rather straight forwardly + + Some examples of me are + + ```lisp + (in-package :geb.poly) + + POLY> (gapply (if-zero (- ident ident 1) 10 ident) 5) + 5 (3 bits, #x5, #o5, #b101) + + POLY> (gapply (if-zero (- ident ident) 10 ident) 5) + 10 (4 bits, #xA, #o12, #b1010) + + POLY> (gapply (- (* 2 ident ident) (* ident ident)) 5) + 25 (5 bits, #x19, #o31, #b11001) + ``` + + +- [method] GAPPLY (MORPHISM INTEGER) OBJECT + + My main documentation can be found on GAPPLY + + I am the GAPPLY for INTEGERs, the + OBJECT that I expect is of type NUMBER. I simply return myself. + + Some examples of me are + + ```lisp + (in-package :geb.poly) + + POLY> (gapply 10 5) + 10 (4 bits, #xA, #o12, #b1010) + ``` + + +### Polynomial Constructors + +###### \[in package GEB.POLY.SPEC\] +Every accessor for each of the CLASS's found here are from @GEB-ACCESSORS + +- [symbol-macro] IDENT + +- [function] + MCAR MCADR &REST ARGS + + Creates a multiway constructor for + + +- [function] * MCAR MCADR &REST ARGS + + Creates a multiway constructor for \* + +- [function] / MCAR MCADR &REST ARGS + + Creates a multiway constructor for / + +- [function] - MCAR MCADR &REST ARGS + + Creates a multiway constructor for - + +- [function] MOD MCAR MCADR + + MOD ARG1 by ARG2 + +- [function] COMPOSE MCAR MCADR &REST ARGS + + Creates a multiway constructor for COMPOSE + +- [function] IF-ZERO PRED THEN ELSE + + checks if PREDICATE is zero then take the THEN branch otherwise + the ELSE branch + +- [function] IF-LT MCAR MCADR THEN ELSE + + Checks if the MCAR is less than the MCADR and chooses the appropriate branch + +### Polynomial Transformations + +###### \[in package GEB.POLY.TRANS\] +This covers transformation functions from + +- [method] TO-CIRCUIT (MORPHISM \) NAME + + Turns a POLY term into a Vamp-IR Gate with the given name + +- [method] TO-VAMPIR (OBJ INTEGER) VALUE LET-VARS + + Numbers act like a constant function, ignoring input + +- [method] TO-VAMPIR (OBJ IDENT) VALUE LET-VARS + + Identity acts as the identity function + +- [method] TO-VAMPIR (OBJ +) VALUE LET-VARS + + Propagates the value and adds them + +- [method] TO-VAMPIR (OBJ \*) VALUE LET-VARS + + Propagates the value and times them + +- [method] TO-VAMPIR (OBJ -) VALUE LET-VARS + + Propagates the value and subtracts them + +- [method] TO-VAMPIR (OBJ /) VALUE LET-VARS + +- [method] TO-VAMPIR (OBJ COMPOSE) VALUE LET-VARS + +- [method] TO-VAMPIR (OBJ IF-ZERO) VALUE LET-VARS + + The PREDICATE that comes in must be 1 or 0 for the formula to work out. + +- [method] TO-VAMPIR (OBJ IF-LT) VALUE LET-VARS + +- [method] TO-VAMPIR (OBJ MOD) VALUE LET-VARS + +## The Simply Typed Lambda Calculus model + +###### \[in package GEB.LAMBDA\] +This covers GEB's view on simply typed lambda calculus + +This serves as a useful frontend for those wishing to write a compiler +to GEB and do not wish to target the categorical model. + +If one is targeting their compiler to the frontend, then the following +code should be useful for you. + +```lisp +(in-package :geb.lambda.main) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (index 0)) + :id) +(def id x1 = { + (x1) + };) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit))))) + :not) +(def not x1 = { + (((1 - x1) * 1) + (x1 * 0), ((1 - x1) * 1) + (x1 * 0)) + };) + +MAIN> (to-circuit (lamb (list geb-bool:bool) + (left so1 (right so1 (index 0)))) :foo) +(def foo x1 = { + (0, 1, x1) + };) +``` + +For testing purposes, it may be useful to go to the `BITC` backend and +run our interpreter + +```lisp +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*1) +#*00 +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*0) +#*11 +``` + + +### Lambda Specification + +###### \[in package GEB.LAMBDA.SPEC\] +This covers the various the abstract data type that is the simply +typed lambda calculus within GEB. The class presents untyped STLC terms. + +- [type] STLC + + Type of untyped terms of STLC. Each class of a term has a slot for a type, + which can be filled by auxillary functions or by user. Types are + represented as SUBSTOBJ. + +- [class] DIRECT-POINTWISE-MIXIN META-MIXIN CAT-OBJ + + Class of untyped terms of simply typed lambda claculus. Given our + presentation, we look at the latter as a type theory spanned by empty, + unit types as well as coproduct, product, and function types. + +- [class] ABSURD \ + + The ABSURD term provides an element of an arbitrary type + given a term of the empty type, denoted by SO0. + The formal grammar of ABSURD is + + ```lisp + (absurd tcod term) + ``` + + where we possibly can include type information by + + ```lisp + (absurd tcod term :ttype ttype) + ``` + + The intended semantics are: TCOD is a type whose term we want to + get (and hence a SUBSTOBJ) and TERM is a term + of the empty type (and hence an STLC. + + This corresponds to the elimination rule of the empty type. Namely, + given + $$\Gamma \vdash \text{tcod : Type}$$ and + $$\Gamma \vdash \text{term : so0}$$ one deduces + $$\Gamma \vdash \text{(absurd tcod term) : tcod}$$ + +- [class] UNIT \ + + The unique term of the unit type, the latter represented by + SO1. The formal grammar of UNIT is + + ```lisp + (unit) + ``` + + where we can optionally include type information by + + ```lisp + (unit :ttype ttype) + ``` + + Clearly the type of UNIT is SO1 but here + we provide all terms untyped. + + This grammar corresponds to the introduction rule of the unit type. Namely + $$\Gamma \dashv \text{(unit) : so1}$$ + +- [class] LEFT \ + + Term of a coproduct type gotten by injecting into the left type of the coproduct. The formal grammar of + LEFT is + + ```lisp + (left rty term) + ``` + + where we can include optional type information by + + ```lisp + (left rty term :ttype ttype) + ``` + + The indended semantics are as follows: RTY should + be a type (and hence a SUBSTOBJ) and specify the + right part of the coproduct of the type TTYPE of + the entire term. The term (and hence an STLC) we are injecting + is TERM. + + This corresponds to the introduction rule of the coproduct type. Namely, given + $$\Gamma \dashv \text{(ttype term) : Type}$$ and + $$\Gamma \dashv \text{rty : Type}$$ + with + $$\Gamma \dashv \text{term : (ttype term)}$$ we deduce + $$\Gamma \dashv \text{(left rty term) : (coprod (ttype term) rty)}$$ + +- [class] RIGHT \ + + Term of a coproduct type gotten by injecting into the right type of + the coproduct. The formal grammar of RIGHT is + + ```lisp + (right lty term) + ``` + + where we can include optional type information by + + ```lisp + (right lty term :ttype ttype) + ``` + + The indended semantics are as follows: LTY should be a type (and + hence a SUBSTOBJ) and specify the left part of + the coproduct of the type TTYPE of the entire term. The term (and + hence an STLC) we are injecting is TERM. + + This corresponds to the introduction rule of the coproduct type. Namely, given + $$\Gamma \dashv \text{(ttype term) : Type}$$ and + $$\Gamma \dashv \text{lty : Type}$$ + with + $$\Gamma \dashv \text{term : (ttype term)}$$ we deduce + $$\Gamma \dashv \text{(right lty term) : (coprod lty (ttype term))}$$ + +- [class] CASE-ON \ + + A term of an arbutrary type provided by casing on a coproduct term. The + formal grammar of CASE-ON is + + ```lisp + (case-on on ltm rtm) + ``` + + where we can possibly include type information by + + ```lisp + (case-on on ltm rtm :ttype ttype) + ``` + + The intended semantics are as follows: ON is a term (and hence an + STLC) of a coproduct type, and LTM and RTM terms (hence + also STLC) of the same type in the context of - appropriately + - (mcar (ttype on)) and (mcadr (ttype on)). + + This corresponds to the elimination rule of the coprodut type. Namely, given + $$\Gamma \vdash \text{on : (coprod (mcar (ttype on)) (mcadr (ttype on)))}$$ + and + $$\text{(mcar (ttype on))} , \Gamma \vdash \text{ltm : (ttype ltm)}$$ + , $$\text{(mcadr (ttype on))} , \Gamma \vdash \text{rtm : (ttype ltm)}$$ + we get + $$\Gamma \vdash \text{(case-on on ltm rtm) : (ttype ltm)}$$ + Note that in practice we append contexts on the left as computation of + INDEX is done from the left. Otherwise, the rules are the same as in + usual type theory if context was read from right to left. + +- [class] PAIR \ + + A term of the product type gotten by pairing a terms of a left and right + parts of the product. The formal grammar of PAIR is + + ```lisp + (pair ltm rtm) + ``` + + where we can possibly include type information by + + ```lisp + (pair ltm rtm :ttype ttype) + ``` + + The intended semantics are as follows: LTM is a term (and hence an + STLC) of a left part of the product type whose terms we are + producing. RTM is a term (hence also STLC)of the right part + of the product. + + The grammar corresponds to the introdcution rule of the pair type. Given + $$\Gamma \vdash \text{ltm : (mcar (ttype (pair ltm rtm)))}$$ and + $$\Gamma \vdash \text{rtm : (mcadr (ttype (pair ltm rtm)))}$$ we have + $$\Gamma \vdash \text{(pair ltm rtm) : (ttype (pair ltm rtm))}$$ + +- [class] FST \ + + The first projection of a term of a product type. + The formal grammar of FST is: + + ```lisp + (fst term) + ``` + + where we can possibly include type information by + + ```lisp + (fst term :ttype ttype) + ``` + + The indended semantics are as follows: TERM is a + term (and hence an STLC) of a product type, to whose left part + we are projecting to. + + This corresponds to the first projection function gotten by induction + on a term of a product type. + +- [class] SND \ + + The second projection of a term of a product type. + The formal grammar of SND is: + + ```lisp + (snd term) + ``` + + where we can possibly include type information by + + ```lisp + (snd term :ttype ttype) + ``` + + The indended semantics are as follows: TERM is a + term (and hence an STLC) of a product type, to whose right + part we are projecting to. + + This corresponds to the second projection function gotten by induction + on a term of a product type. + +- [class] LAMB \ + + A term of a function type gotten by providing a term in the codomain + of the function type by assuming one is given variables in the + specified list of types. LAMB takes in the TDOM + accessor a list of types - and hence of SUBSTOBJ - and in the + TERM a term - and hence an STLC. The formal grammar + of LAMB is: + + ```lisp + (lamb tdom term) + ``` + + where we can possibly include type information by + + ```lisp + (lamb tdom term :ttype ttype) + ``` + + The intended semnatics are: TDOM is a list of types (and + hence a list of SUBSTOBJ) whose iterative product of + components form the domain of the function type. TERM + is a term (and hence an STLC) of the codomain of the function type + gotten in the context to whom we append the list of the domains. + + For a list of length 1, corresponds to the introduction rule of the function + type. Namely, given + $$\Gamma \vdash \text{tdom : Type}$$ and + $$\Gamma, \text{tdom} \vdash \text{term : (ttype term)}$$ we have + $$\Gamma \vdash \text{(lamb tdom term) : (so-hom-obj tdom (ttype term))}$$ + + For a list of length n, this coreesponds to the iterated lambda type, e.g. + + ```lisp + (lamb (list so1 so0) (index 0)) + ``` + + is a term of + + ```lisp + (so-hom-obj (prod so1 so0) so0) + ``` + + or equivalently + + ```lisp + (so-hom-obj so1 (so-hom-obj so0 so0)) + ``` + + due to Geb's computational definition of the function type. + + Note that INDEX 0 in the above code is of type SO1. + So that after annotating the term, one gets + + ```lisp + LAMBDA> (ttype (term (lamb (list so1 so0)) (index 0))) + s-1 + ``` + + So the counting of indeces starts with the leftmost argument for + computational reasons. In practice, typing of LAMB corresponds with + taking a list of arguments provided to a lambda term, making it a context + in that order and then counting the index of the varibale. Type-theoretically, + + $$\Gamma \vdash \lambda \Delta (index i)$$ + $$\Delta, \Gamma \vdash (index i)$$ + + So that by the operational semantics of INDEX, the type of (index i) + in the above context will be the i'th element of the Delta context counted from + the left. Note that in practice we append contexts on the left as computation of + INDEX is done from the left. Otherwise, the rules are the same as in + usual type theory if context was read from right to left. + +- [class] APP \ + + A term of an arbitrary type gotten by applying a function of an iterated + function type with a corresponding codomain iteratively to terms in the + domains. APP takes as argument for the FUN accessor + a function - and hence an STLC - whose function type has domain an + iterated GEB:PROD of [SUBSTOBJ][clas] and for the TERM + a list of terms - and hence of STLC - matching the types of the + product. The formal grammar of APP is + + ```lisp + (app fun term) + ``` + + where we can possibly include type information by + + ```lisp + (app fun term :ttype ttype) + ``` + + The intended semantics are as follows: + FUN is a term (and hence an STLC) of a coproduct + type - say of (so-hom-obj (ttype term) y) - and TERM is a + list of terms (hence also of STLC) with nth term in the list having the + n-th part of the function type. + + For a one-argument term list, this corresponds to the elimination rule of the + function type. Given + $$\Gamma \vdash \text{fun : (so-hom-obj (ttype term) y)}$$ and + $$\Gamma \vdash \text{term : (ttype term)}$$ we get + $$\Gamma \vdash \text{(app fun term) : y}$$ + + For several arguments, this corresponds to successive function application. + Using currying, this corresponds to, given + + ``` + G ⊢ (so-hom-obj (A₁ × ··· × Aₙ₋₁) Aₙ) + G ⊢ f : (so-hom-obj (A₁ × ··· × Aₙ₋₁) + G ⊢ tᵢ : Aᵢ + ``` + + then for each `i` less than `n` gets us + + ```lisp + G ⊢ (app f t₁ ··· tₙ₋₁) : Aₙ + ``` + + Note again that i'th term should correspond to the ith element of the product + in the codomain counted from the left. + +- [class] INDEX \ + + The variable term of an arbitrary type in a context. The formal + grammar of INDEX is + + ```lisp + (index pos) + ``` + + where we can possibly include type information by + + ```lisp + (index pos :ttype ttype) + ``` + + The intended semantics are as follows: POS is a + natural number indicating the position of a type in a context. + + This corresponds to the variable rule. Namely given a context + $$\Gamma\_1 , \ldots , \Gamma\_{pos} , \ldots , \Gamma\_k $$ we have + + $$\Gamma\_1 , \ldots , \Gamma\_k \vdash \text{(index pos) :} \Gamma\_{pos}$$ + + Note that we add contexts on the left rather than on the right contra classical + type-theoretic notation. + +- [function] ABSURD TCOD TERM &KEY (TTYPE NIL) + +- [function] UNIT &KEY (TTYPE NIL) + +- [function] LEFT RTY TERM &KEY (TTYPE NIL) + +- [function] RIGHT LTY TERM &KEY (TTYPE NIL) + +- [function] CASE-ON ON LTM RTM &KEY (TTYPE NIL) + +- [function] PAIR LTM RTM &KEY (TTYPE NIL) + +- [function] FST TERM &KEY (TTYPE NIL) + +- [function] SND TERM &KEY (TTYPE NIL) + +- [function] LAMB TDOM TERM &KEY (TTYPE NIL) + +- [function] APP FUN TERM &KEY (TTYPE NIL) + +- [function] INDEX POS &KEY (TTYPE NIL) + +Accessors of ABSURD + +- [method] TCOD (ABSURD ABSURD) + + An arbitrary type + +- [method] TERM (ABSURD ABSURD) + + A term of the empty type + +- [method] TTYPE (ABSURD ABSURD) + +Accessors of UNIT + +- [method] TTYPE (UNIT UNIT) + +Accessors of LEFT + +- [method] RTY (LEFT LEFT) + + Right argument of coproduct type + +- [method] TERM (LEFT LEFT) + + Term of the left argument of coproduct type + +- [method] TTYPE (LEFT LEFT) + +Accessors of RIGHT + +- [method] LTY (RIGHT RIGHT) + + Left argument of coproduct type + +- [method] TERM (RIGHT RIGHT) + + Term of the right argument of coproduct type + +- [method] TTYPE (RIGHT RIGHT) + +Accessors of CASE-ON + +- [method] ON (CASE-ON CASE-ON) + + Term of coproduct type + +- [method] LTM (CASE-ON CASE-ON) + + Term in context of left argument of coproduct type + +- [method] RTM (CASE-ON CASE-ON) + + Term in context of right argument of coproduct type + +- [method] TTYPE (CASE-ON CASE-ON) + +Accessors of PAIR + +- [method] LTM (PAIR PAIR) + + Term of left argument of the product type + +- [method] RTM (PAIR PAIR) + + Term of right argument of the product type + +- [method] TTYPE (PAIR PAIR) + +Accessors of FST + +- [method] TERM (FST FST) + + Term of product type + +- [method] TTYPE (FST FST) + +Accessors of SND + +- [method] TERM (SND SND) + + Term of product type + +- [method] TTYPE (SND SND) + +Accessors of LAMB + +- [method] TDOM (LAMB LAMB) + + Domain of the lambda term + +- [method] TERM (LAMB LAMB) + + Term of the codomain mapped to given a variable of tdom + +- [method] TTYPE (LAMB LAMB) + +Accessors of APP + +- [method] FUN (APP APP) + + Term of exponential type + +- [method] TERM (APP APP) + + List of Terms of the domain + +- [method] TTYPE (APP APP) + +Accessors of INDEX + +- [method] POS (INDEX INDEX) + + Position of type + +- [method] TTYPE (INDEX INDEX) + +- [generic-function] TCOD OBJ + +- [generic-function] TDOM OBJ + +- [generic-function] TERM OBJ + +- [generic-function] RTY OBJ + +- [generic-function] LTY OBJ + +- [generic-function] LTM OBJ + +- [generic-function] RTM OBJ + +- [generic-function] ON OBJ + +- [generic-function] FUN OBJ + +- [generic-function] POS OBJ + +- [generic-function] TTYPE OBJ + +### Main functionality + +###### \[in package GEB.LAMBDA.MAIN\] +This covers the main API for the STLC module + +- [generic-function] ANN-TERM1 CTX TTERM + + Given a list of SUBSTOBJ objects with + SO-HOM-OBJ occurences replaced by FUN-TYPE + and an STLC similarly replacing type occurences of the hom object + to FUN-TYPE, provides the TTYPE accessor to all + subterms as well as the term itself, using FUN-TYPE. Once again, + note that it is important for the context and term to be giving as + per above description. While not always, not doing so result in an error upon + evaluation. As an example of a valid entry we have + + ```lisp + (ann-term1 (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) + ``` + + while + + ```lisp + (ann-term1 (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) + ``` + + produces an error trying to use HOM-COD. This warning applies to other + functions taking in context and terms below as well. + + Moreover, note that for terms whose typing needs addition of new context + we append contexts on the left rather than on the right contra usual type + theoretic notation for the convenience of computation. That means, e.g. that + asking for a type of a lambda term as below produces: + + ```lisp + LAMBDA> (ttype (term (ann-term1 (lambda (list so1 so0) (index 0))))) + s-1 + ``` + + as we count indeces from the left of the context while appending new types to + the context on the left as well. For more info check LAMB + +- [function] HOM-COD CTX F + + Given a context of SUBSTOBJ with occurences of + SO-HOM-OBJ replaced by FUN-TYPE, and similarly + an STLC term of the stand-in for the hom object, produces the stand-in + to the codomain. + +- [function] INDEX-CHECK I CTX + + Given an natural number I and a context, checks that the context is of + length at least I and then produces the Ith entry of the context counted + from the left starting with 0. + +- [function] FUN-TO-HOM T1 + + Given a SUBSTOBJ whose subobjects might have a + FUN-TYPE occurence replaces all occurences of FUN-TYPE with a + suitable SO-HOM-OBJ, hence giving a pure + SUBSTOBJ + + ```lisp + LAMBDA> (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)) + (× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) + ``` + + +- [function] ANN-TERM2 TTERM + + Given an STLC term with a TTYPE accessor from + ANN-TERM1 - i.e. including possible FUN-TYPE + occurences - re-annotates the term and its subterms with actual + SUBSTOBJ objects. + +- [function] ANNOTATED-TERM CTX TERM + + Given a context consisting of a list of SUBSTOBJ + with occurences of SO-HOM-OBJ replaced by + FUN-TYPE and an STLC term with similarly replaced occurences + of SO-HOM-OBJ, provides an STLC with all + subterms typed, i.e. providing the TTYPE accessor, + which is a pure SUBSTOBJ + +- [function] TYPE-OF-TERM-W-FUN CTX TTERM + + Given a context consisting of a list of SUBSTOBJ with + occurences of SO-HOM-OBJ replaced by FUN-TYPE + and an STLC term with similarly replaced occurences of + SO-HOM-OBJ, gives out a type of the whole term with + occurences of SO-HOM-OBJ replaced by FUN-TYPE. + +- [function] TYPE-OF-TERM CTX TTERM + + Given a context consisting of a list of SUBSTOBJ with + occurences of SO-HOM-OBJ replaced by FUN-TYPE + and an STLC term with similarly replaced occurences of + SO-HOM-OBJ, provides the type of the whole term, + which is a pure SUBSTOBJ. + +- [generic-function] WELL-DEFP CTX TTERM + + Given a context consisting of a list of SUBSTOBJ + with occurences of SO-HOM-OBJ replaced by + FUN-TYPE and an STLC term with similarly replaced + occurences of SO-HOM-OBJ, checks that the term + is well-defined in the context based on structural rules of simply + typed lambda calculus. returns the t if it is, otherwise returning + nil + +- [class] FUN-TYPE DIRECT-POINTWISE-MIXIN CAT-OBJ + + Stand-in for the SO-HOM-OBJ object. It does not have + any computational properties and can be seen as just a function of two arguments + with accessors MCAR to the first argument and + MCADR to the second argument. There is an evident canonical + way to associate FUN-TYPE and SO-HOM-OBJ + pointwise. + +- [function] FUN-TYPE MCAR MCADR + +- [method] MCAR (FUN-TYPE FUN-TYPE) + +- [method] MCADR (FUN-TYPE FUN-TYPE) + +- [generic-function] MCAR OBJ + + Can be seen as calling CAR on a generic CLOS + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + +- [generic-function] MCADR OBJ + + like MCAR but for the CADR ### Transition Functions @@ -1814,13 +3070,83 @@ This covers the main API for the STLC module These functions deal with transforming the data structure to other data types -- [generic-function] COMPILE-CHECKED-TERM CONTEXT TYPE TERM +One important note about the lambda conversions is that all +transition functions except TO-CAT do not take a context. - Compiles a checked term into SubstMorph category +Thus if the term contains free variables, then call +TO-CAT and give it the desired context before calling +any other transition functions + +- [method] TO-CAT CONTEXT (TTERM \) + + Compiles a checked term in an appropriate context into the + morphism of the GEB category. In detail, it takes a context and a term with + following restrictions: Terms come from STLC with occurences of + SO-HOM-OBJ replaced by FUN-TYPE and should + come without the slow of TTYPE accessor filled for any of + the subterms. Context should be a list of SUBSTOBJ with + the caveat that instead of SO-HOM-OBJ we ought to use + FUN-TYPE, a stand-in for the internal hom object with explicit + accessors to the domain and the codomain. Once again, note that it is important + for the context and term to be giving as per above description. While not + always, not doing so result in an error upon evaluation. As an example of a + valid entry we have + + ```lisp + (to-cat (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) + ``` + + while + + ```lisp + (to-cat (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) + ``` + + produces an error. Error of such kind mind pop up both on the level of evaluating + WELL-DEFP and ANN-TERM1. + + Moreover, note that for terms whose typing needs addition of new context + we append contexts on the left rather than on the right contra usual type + theoretic notation for the convenience of computation. That means, e.g. that + asking for a type of a lambda term as below produces: + + ```lisp + LAMBDA> (ttype (term (ann-term1 nil (lamb (list so1 so0) (index 0))))) + s-1 + ``` + + as we count indeces from the left of the context while appending new types to + the context on the left as well. For more info check LAMB -- [function] TO-POLY CONTEXT TYPE OBJ +- [method] TO-POLY (OBJ \) -- [function] TO-CIRCUIT CONTEXT TYPE OBJ NAME + I convert a lambda term into a GEB.POLY.SPEC:POLY term + + Note that terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call to-cat before + calling me + +- [method] TO-BITC (OBJ \) + + I convert a lambda term into a GEB.BITC.SPEC:BITC term + + Note that terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call to-cat before + calling me + +- [method] TO-CIRCUIT (OBJ \) NAME + + I convert a lambda term into a vampir term + + Note that terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call to-cat before + calling me #### Utility Functionality @@ -1828,7 +3154,18 @@ These are utility functions relating to translating lambda terms to other types - [function] STLC-CTX-TO-MU CONTEXT - Converts a generic context into a SUBSTMORPH + Converts a generic context into a + SUBSTMORPH. Note that usually contexts can be interpreted + in a category as a $Sigma$-type$, which in a non-dependent setting gives us a + usual PROD + + ```lisp + LAMBDA> (stlc-ctx-to-mu (list so1 (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)))) + (× s-1 + (× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) + s-1) + ``` + - [function] SO-HOM DOM COD @@ -1896,6 +3233,10 @@ traversal as `LIST`'s are Works like C2MOP:COMPUTE-SLOTS however on the object rather than the class +- [function] MAP-POINTWISE FUNCTION OBJ + +- [function] REDUCE-POINTWISE FUNCTION OBJ INITIAL + ### Mixins Examples Let's see some example uses of POINTWISE-MIXIN: @@ -2081,6 +3422,17 @@ used throughout the GEB codebase - [function] SHALLOW-COPY-OBJECT ORIGINAL +- [generic-function] COPY-INSTANCE OBJECT &REST INITARGS &KEY &ALLOW-OTHER-KEYS + + Makes and returns a shallow copy of OBJECT. + + An uninitialized object of the same class as OBJECT is allocated by + calling ALLOCATE-INSTANCE. For all slots returned by + CLASS-SLOTS, the returned object has the + same slot values and slot-unbound status as OBJECT. + + REINITIALIZE-INSTANCE is called to update the copy with INITARGS. + - [macro] MAKE-PATTERN OBJECT-NAME &REST CONSTRUCTOR-NAMES make pattern matching position style instead of record style. This @@ -2114,6 +3466,16 @@ used throughout the GEB codebase Turns an INTEGER into a subscripted STRING +- [function] APPLY-N TIMES F INITIAL + + Applies a function, f, n TIMES to the INITIAL values + + ```lisp + GEB> (apply-n 10 #'1+ 0) + 10 (4 bits, #xA, #o12, #b1010) + ``` + + ### Accessors These functions are generic lenses of the GEB codebase. If a class is @@ -2172,6 +3534,11 @@ likely to be used. They may even augment existing classes. the then branch of the [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) +- [generic-function] CODE OBJ + + the code of the + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + ## Testing ###### \[in package GEB-TEST\] diff --git a/README.md b/README.md index 7e556e773..7951e5d32 100644 --- a/README.md +++ b/README.md @@ -24,40 +24,50 @@ - [6.3 ≺Types≻][a300] - [7 The Geb Model][c1fb] - [7.1 The Categorical Interface][e91b] - - [7.2 Core Category][cb9e] - - [7.2.1 Subst Obj][c1b3] - - [7.2.2 Subst Morph][d2d1] - - [7.3 Accessors][cc51] - - [7.4 Constructors][2ad4] - - [7.5 API][6228] - - [7.5.1 Booleans][399c] - - [7.5.2 Translation Functions][b79a] - - [7.5.3 Utility][49d4] - - [7.6 Examples][a17b] -- [8 The GEB GUI][6f67] - - [8.1 Visualizer][c6cf] - - [8.1.1 Aiding the Visualizer][603e] - - [8.2 The GEB Graphizer][1b98] - - [8.2.1 The GEB Graphizer Core][71e9] - - [8.2.2 The GEB Graphizer Passes][e429] -- [9 Polynomial Specification][94a8] - - [9.1 Polynomial Types][bd81] - - [9.2 Polynomial Constructors][b76d] - - [9.3 Polynomial Transformations][0f3e] -- [10 The Simply Typed Lambda Calculus model][db8f] - - [10.1 Lambda Specification][34d0] - - [10.2 Main functionality][d2d5] - - [10.3 Transition Functions][e3e4] - - [10.3.1 Utility Functionality][0609] -- [11 Mixins][723a] - - [11.1 Pointwise Mixins][d5d3] - - [11.2 Pointwise API][2fcf] - - [11.3 Mixins Examples][4938] - - [11.4 Metadata Mixin][9300] - - [11.4.1 Performance][455b] -- [12 Geb Utilities][4ffa] - - [12.1 Accessors][cc51] -- [13 Testing][9bcb] + - [7.2 Geneircs][a84b] + - [7.3 Core Category][cb9e] + - [7.3.1 Subst Obj][c1b3] + - [7.3.2 Subst Morph][d2d1] + - [7.3.3 Realized Subst Objs][dca9] + - [7.4 Accessors][cc51] + - [7.5 Constructors][2ad4] + - [7.6 API][6228] + - [7.6.1 Booleans][399c] + - [7.6.2 Lists][1c91] + - [7.6.3 Translation Functions][b79a] + - [7.6.4 Utility][49d4] + - [7.7 Examples][a17b] +- [8 Extension Sets for Categories][0efa] +- [9 The GEB GUI][6f67] + - [9.1 Visualizer][c6cf] + - [9.1.1 Aiding the Visualizer][603e] + - [9.2 The GEB Graphizer][1b98] + - [9.2.1 The GEB Graphizer Core][71e9] + - [9.2.2 The GEB Graphizer Passes][e429] +- [10 Bits (Boolean Circuit) Specification][6b63] + - [10.1 Bits Types][2172] + - [10.2 Bits (Boolean Circuit) Constructors][fc10] + - [10.3 Bits (Boolean Circuit) API][4659] + - [10.4 Bits (Boolean Circuit) Transformations][2ebc] +- [11 Polynomial Specification][94a8] + - [11.1 Polynomial Types][bd81] + - [11.2 Polynomial API][0251] + - [11.3 Polynomial Constructors][b76d] + - [11.4 Polynomial Transformations][0f3e] +- [12 The Simply Typed Lambda Calculus model][db8f] + - [12.1 Lambda Specification][34d0] + - [12.2 Main functionality][d2d5] + - [12.3 Transition Functions][e3e4] + - [12.3.1 Utility Functionality][0609] +- [13 Mixins][723a] + - [13.1 Pointwise Mixins][d5d3] + - [13.2 Pointwise API][2fcf] + - [13.3 Mixins Examples][4938] + - [13.4 Metadata Mixin][9300] + - [13.4.1 Performance][455b] +- [14 Geb Utilities][4ffa] + - [14.1 Accessors][cc51] +- [15 Testing][9bcb] ###### \[in package GEB-DOCS/DOCS\] Welcome to the GEB project. @@ -65,13 +75,19 @@ Welcome to the GEB project. ## 1 Links + + Here is the [official repository](https://github.com/anoma/geb/) and [HTML documentation](https://anoma.github.io/geb/) for the latest version. + + ### 1.1 code coverage + + For test coverage it can be found at the following links: [SBCL test coverage](./tests/cover-index.html) @@ -89,6 +105,8 @@ I recommend reading the CCL code coverage version, as it has proper tags. Currently they are manually generated, and thus for a more accurate assessment see [`GEB-TEST:CODE-COVERAGE`][417f] + + ## 2 Getting Started @@ -169,13 +187,13 @@ to use An example use of this binary is as follows ```bash -mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.spec::*entry*" -l -v -o "foo.pir" +mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.main::*entry*" -l -v -o "foo.pir" mariari@Gensokyo % cat foo.pir -def *entry* x { - 0 -}% -mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.spec::*entry*" -l -v +def entry x1 = { + (x1) +};% +mariari@Gensokyo % ./geb.image -i "foo.lisp" -e "geb.lambda.main::*entry*" -l -v def *entry* x { 0 } @@ -193,11 +211,18 @@ def *entry* x { starting from a file *foo.lisp* that has +any valid lambda form. Good examples can be found at the following section: + +[The Simply Typed Lambda Calculus model][db8f] + +with the term bound to some global variable + ```lisp -(in-package :geb.lambda.spec) +(in-package :geb.lambda.main) (defparameter *entry* - (typed unit geb:so1)) + (lamb (list (coprod so1 so1)) + (index 0))) ``` inside of it. @@ -249,8 +274,8 @@ lambda term rather than a geb term. In time this will go away project-left project-right)) ``` - This type is closed, as only one of [`GEB:SUBSTOBJ`][3173], [`GEB:INJECT-LEFT`][cab9], - [`GEB:INJECT-RIGHT`][fae9] etc can form the [`GEB:SUBSTMORPH`][57dc] type. + This type is closed, as only one of [`GEB:SUBSTOBJ`][3173], [`GEB:INJECT-LEFT`][8387], + [`GEB:INJECT-RIGHT`][e947] etc can form the [`GEB:SUBSTMORPH`][57dc] type. The main benefit of this form is that we can be exhaustive over what can be found in `GEB:SUBSTMORPH`. @@ -266,7 +291,7 @@ lambda term rather than a geb term. In time this will go away ((prod x y) (so-hom-obj x (so-hom-obj y z))))) ``` - If we forget a case, like [`GEB:COPROD`][fb12] it wanrs us with an non exhaustion warning. + If we forget a case, like [`GEB:COPROD`][8be5] it wanrs us with an non exhaustion warning. Meaning that if we update definitions this works well. @@ -296,7 +321,7 @@ lambda term rather than a geb term. In time this will go away (defclass so0 () ()) ``` - Now any methods on [`GEB:`][8214] will cover `GEB:SO0`([`0`][7088] [`1`][1f3a]). + Now any methods on [`GEB:`][fb79] will cover `GEB:SO0`([`0`][5c7c] [`1`][7088]). --- @@ -350,6 +375,8 @@ conjectures about GEB ## 5 Categorical Model + + Geb is organizing programming language concepts (and entities!) using [category theory](https://plato.stanford.edu/entries/category-theory/), originally developed by mathematicians, @@ -417,31 +444,31 @@ In particular, we shall rely on the following universal constructions: -1. The construction of binary products $A × B$ of sets $A,B$, and the empty product $\mathsf{1}$. +1. The construction of binary products $A × B$ of sets $A,B$, and the empty product $mathsf{1}$. 2. The construction of “function spaces” $B^A$ of sets $A,B$, called *exponentials*, i.e., collections of functions between pairs of sets. 3. The so-called [*currying*](https://en.wikipedia.org/wiki/Currying) of functions, - $C^{(B^A)} \cong C^{(A × B)}$, + $C^{(B^A)} cong C^{(A × B)}$, such that providing several arguments to a function can done either simultaneously, or in sequence. 4. The construction of sums (a.k.a. co-products) $A + B$ of sets $A,B$, corresponding to forming disjoint unions of sets; - the empty sum is $\varnothing$. + the empty sum is $varnothing$. Product, sums and exponentials are the (almost) complete tool chest for writing polynomial expressions, e.g., -$$Ax^{\sf 2} +x^{\sf 1} - Dx^{\sf 0}.$$ +$$Ax^{sf 2} +x^{sf 1} - Dx^{sf 0}.$$ (We need these later to define [“algebraic data types”](https://en.wikipedia.org/wiki/Polynomial_functor_(type_theory)).) In the above expression, we have sets instead of numbers/constants -where $ \mathsf{2} = \lbrace 1, 2 \rbrace$, -$ \mathsf{1} = \lbrace 1 \rbrace$, -$ \mathsf{0} = \lbrace \rbrace = \varnothing$, +where $ mathsf{2} = lbrace 1, 2 rbrace$, +$ mathsf{1} = lbrace 1 rbrace$, +$ mathsf{0} = lbrace rbrace = varnothing$, and $A$ and $B$ are arbitrary (finite) sets. We are only missing a counterpart for the *variable*! Raising an arbitrary set to “the power” of a constant set @@ -464,6 +491,8 @@ Benjamin Pierce's as it is very amenable *and* covers the background we need in 60 short pages. + + ### 5.1 Morphisms @@ -558,10 +587,10 @@ idiom. The [closed type][8932] is [`GEB:SUBSTOBJ`][3173], filling and defining every structure it knows about. This is a fixed idea that a programmer may statically -update and get exhaustive warnings about. Whereas [`GEB:`][8214] is -the open interface for the type. Thus we can view [`GEB:`][8214] as +update and get exhaustive warnings about. Whereas [`GEB:`][fb79] is +the open interface for the type. Thus we can view [`GEB:`][fb79] as the general idea of a [`GEB:SUBSTOBJ`][3173]. Before delving into how we combine -these methods, let us look at two other benefits given by [`GEB:`][8214] +these methods, let us look at two other benefits given by [`GEB:`][fb79] 1. We can put all the [Mixins][723a] into the superclass to enforce that any type that extends it has the extended behaviors we wish. This is a @@ -606,13 +635,13 @@ In this piece of code we can notice a few things: 1. We case on [`GEB:SUBSTMORPH`][57dc] exhaustively -2. We cannot hit the [`GEB:`][8214] case due to method dispatch +2. We cannot hit the [`GEB:`][fb79] case due to method dispatch 3. We have this [`GEB.UTILS:SUBCLASS-RESPONSIBILITY`][2276] function getting called. 4. We can write further methods extending the function to other subtypes. -Thus the [`GEB:TO-POLY`][642a] function is written in such a way that it +Thus the [`GEB.COMMON:TO-POLY`][2eb9] function is written in such a way that it supports a closed definition and open extensions, with [`GEB.UTILS:SUBCLASS-RESPONSIBILITY`][2276] serving to be called if an extension a user wrote has no handling of this method. @@ -688,8 +717,81 @@ contained in various data structures Use [`GEB.MAIN:CURRY`][2cbc] instead. + +### 7.2 Geneircs + +###### \[in package GEB.GENERICS\] +These functions represent the generic functions that can be run on +many parts of the compiler, they are typically rexported on any +package that implements the given generic function. + +You can view their documentation in their respective API sections. + +The main documentation for the functionality is given here, with +examples often given in the specific methods + + +- [generic-function] **GAPPLY** *MORPHISM OBJECT* + + Applies a given Moprhism to a given object. + + This is practically a naive interpreter for any category found + throughout the codebase. + + Some example usages of `GAPPLY` are. + + ```lisp + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (left so1)) + (right s-1) + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (right so1)) + (left s-1) + ``` + + + +- [generic-function] **TO-CIRCUIT** *MORPHISM NAME* + + Turns a `MORPHISM` into a Vampir circuit. the `NAME` is the given name of + the output circuit. + + +- [generic-function] **TO-BITC** *MORPHISM* + + Turns a given `MORPHISM` into a [`GEB.BITC.SPEC:BITC`][e017] + + +- [generic-function] **TO-POLY** *MORPHISM* + + Turns a given `MORPHISM` into a [`GEB.POLY.SPEC:POLY`][8bf3] + + +- [generic-function] **TO-CAT** *CONTEXT TERM* + + Turns a `MORPHISM` with a context into Geb's Core category + + +- [generic-function] **TO-VAMPIR** *MORPHISM VALUES CONSTRAINTS* + + Turns a `MORPHISM` into a Vampir circuit, with concrete values. + + The more natural interface is [`TO-CIRCUIT`][b0d9], however this is a more low + level interface into what the polynomial categories actually + implement, and thus can be extended or changed. + + The `VALUES` are likely vampir values in a list. + + The `CONSTRAINTS` represent constraints that get creating + -### 7.2 Core Category +### 7.3 Core Category ###### \[in package GEB.SPEC\] The underlying category of GEB. With [Subst Obj][c1b3] covering the @@ -706,18 +808,18 @@ A good example of this category at work can be found within the [Booleans][399c] section. -#### 7.2.1 Subst Obj +#### 7.3.1 Subst Obj This section covers the objects of the [`SUBSTMORPH`][57dc] category. Note that [`SUBSTOBJ`][3173] refers to the -[closed type][8932], whereas [``][8214] refers +[closed type][8932], whereas [``][fb79] refers to the [open type][4a87] that allows for user extension. - [type] **SUBSTOBJ** - -- [type] **\** + +- [class] **\** *[\][db35] [DIRECT-POINTWISE-MIXIN][e2b0] [META-MIXIN][4529] [CAT-OBJ][74bd]* the class corresponding to [`SUBSTOBJ`][3173]. See [Open Types versus Closed Types][a920] @@ -733,19 +835,19 @@ type substobj = so0 ``` - -- [type] **PROD** + +- [class] **PROD** *[\][fb79]* - The [PRODUCT][77c2] object. Takes two [`CAT-OBJ`][74bd] values that + The [PRODUCT][06c6] object. Takes two [`CAT-OBJ`][74bd] values that get put into a pair. - The formal grammar of [PRODUCT][77c2] is + The formal grammar of [PRODUCT][06c6] is ```lisp (prod mcar mcadr) ``` - where [`PROD`][77c2] is the constructor, [`MCAR`][f1ce] is the left value of the + where [`PROD`][06c6] is the constructor, [`MCAR`][f1ce] is the left value of the product, and [`MCADR`][cc87] is the right value of the product. Example: @@ -756,19 +858,19 @@ type substobj = so0 Here we create a product of two [`GEB-BOOL:BOOL`][0ad4] types. - -- [type] **COPROD** + +- [class] **COPROD** *[\][fb79]* - the [CO-PRODUCT][fb12] object. Takes [`CAT-OBJ`][74bd] values that + the [CO-PRODUCT][8be5] object. Takes [`CAT-OBJ`][74bd] values that get put into a choice of either value. - The formal grammar of [PRODUCT][77c2] is + The formal grammar of [PRODUCT][06c6] is ```lisp (coprod mcar mcadr) ``` - Where [CORPOD][e755] is the constructor, [`MCAR`][f1ce] is the left choice of + Where [CORPOD][7e58] is the constructor, [`MCAR`][f1ce] is the left choice of the sum, and [`MCADR`][cc87] is the right choice of the sum. Example: @@ -780,38 +882,38 @@ type substobj = so0 Here we create the boolean type, having a choice between two unit values. - -- [type] **SO0** + +- [class] **SO0** *[\][fb79]* The Initial Object. This is sometimes known as the [VOID](https://en.wikipedia.org/wiki/Void_type) type. - the formal grammar of [`SO0`][1f3a] is + the formal grammar of [`SO0`][5c7c] is ```lisp so0 ``` - where [`SO0`][1f3a] is [`THE`][c767] initial object. + where [`SO0`][5c7c] is [`THE`][c767] initial object. Example `lisp ` - -- [type] **SO1** + +- [class] **SO1** *[\][fb79]* The Terminal Object. This is sometimes referred to as the [Unit](https://en.wikipedia.org/wiki/Unit_type) type. - the formal grammar or [`SO1`][ebf5] is + the formal grammar or [`SO1`][5cfe] is ```lisp so1 ``` - where [`SO1`][ebf5] is [`THE`][c767] terminal object + where [`SO1`][5cfe] is [`THE`][c767] terminal object Example @@ -847,11 +949,11 @@ The [Accessors][cc51] specific to [Subst Obj][c1b3] - [method] **MCADR** *(COPROD COPROD)* -#### 7.2.2 Subst Morph +#### 7.3.2 Subst Morph The overarching types that categorizes the [`SUBSTMORPH`][57dc] category. Note that [`SUBSTMORPH`][57dc] refers to the -[closed type][8932], whereas [``][97fb] refers +[closed type][8932], whereas [``][db35] refers to the [open type][4a87] that allows for user extension. @@ -859,8 +961,8 @@ to the [open type][4a87] that allows for user extension. The morphisms of the [`SUBSTMORPH`][57dc] category - -- [type] **\** + +- [class] **\** *[DIRECT-POINTWISE-MIXIN][e2b0] [META-MIXIN][4529] [CAT-MORPH][a7af]* the class type corresponding to [`SUBSTMORPH`][57dc]. See [Open Types versus Closed Types][a920] @@ -887,13 +989,13 @@ morphism to the layout specified by the given [`SUBSTOBJ`][3173]. Thus we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a [`SUBSTMORPH`][57dc] - -- [type] **COMP** + +- [class] **COMP** *[\][db35]* The composition morphism. Takes two [`CAT-MORPH`][a7af] values that get applied in standard composition order. - The formal grammar of [`COMP`][f914] is + The formal grammar of [`COMP`][ce5b] is ```lisp (comp mcar mcadr) @@ -905,7 +1007,7 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a g 。f ``` - Where [`COMP`][f914]( 。) is the constructor, [`MCAR`][f1ce](g) is the second morphism + Where [`COMP`][ce5b]( 。) is the constructor, [`MCAR`][f1ce](g) is the second morphism that gets applied, and [`MCADR`][cc87](f) is the first morphism that gets applied. @@ -920,13 +1022,13 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` In this example we are composing two morphisms. the first morphism - that gets applied ([`PAIR`][3bc6] ...) is the identity function on the - type ([`PROD`][77c2] [`SO1`][ebf5] [`GEB-BOOL:BOOL`][0ad4]), where we pair the + that gets applied ([`PAIR`][dfa2] ...) is the identity function on the + type ([`PROD`][06c6] [`SO1`][5cfe] [`GEB-BOOL:BOOL`][0ad4]), where we pair the [left projection](PROJECT-LEFT) and the [right projection](PROJECT-RIGHT), followed by taking the [right projection](PROJECT-RIGHT) of the type. - Since we know ([`COMP`][f914] f id) is just f per the laws of category + Since we know ([`COMP`][ce5b] f id) is just f per the laws of category theory, this expression just reduces to ```lisp @@ -934,15 +1036,15 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` - -- [type] **CASE** + +- [class] **CASE** *[\][db35]* Eliminates coproducts. Namely Takes two [`CAT-MORPH`][a7af] values, one gets applied on the left coproduct while the other gets applied on the right coproduct. The result of each `CAT-MORPH` values must be the same. - The formal grammar of [`CASE`][59dd] is: + The formal grammar of [`CASE`][5d7c] is: ```lisp (mcase mcar mcadr) @@ -962,24 +1064,24 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` In the second example, we inject a term with the shape [`GEB-BOOL:BOOL`][0ad4] - into a pair with the shape ([`SO1`][ebf5] × [`GEB-BOOL:BOOL`][0ad4]), then we use - [`MCASE`][cd11] to denote a morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][f4ba] [`1`][ebf5]), + into a pair with the shape ([`SO1`][5cfe] × [`GEB-BOOL:BOOL`][0ad4]), then we use + [`MCASE`][cd11] to denote a morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][5cfe] [`1`][f4ba]), then give us True, otherwise flip the value of the boolean coming in. - -- [type] **INIT** + +- [class] **INIT** *[\][db35]* - The [INITIAL][f899] Morphism, takes any [`CAT-OBJ`][74bd] and - creates a moprhism from [`SO0`][1f3a] (also known as void) to the object given. + The [INITIAL][8e11] Morphism, takes any [`CAT-OBJ`][74bd] and + creates a moprhism from [`SO0`][5c7c] (also known as void) to the object given. - The formal grammar of [INITIAL][f899] is + The formal grammar of [INITIAL][8e11] is ```lisp (init obj) ``` - where [`INIT`][f899] is the constructor. [`OBJ`][f1e6] is the type of object - that will be conjured up from [`SO0`][1f3a], when the morphism is + where [`INIT`][8e11] is the constructor. [`OBJ`][f1e6] is the type of object + that will be conjured up from [`SO0`][5c7c], when the morphism is applied onto an object. Example: @@ -990,20 +1092,20 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a In this example we are creating a unit value out of void. - -- [type] **TERMINAL** + +- [class] **TERMINAL** *[\][db35]* - The [`TERMINAL`][ae41] morphism, Takes any [`CAT-OBJ`][74bd] and creates a - morphism from that object to [`SO1`][ebf5] (also known as unit). + The [`TERMINAL`][874b] morphism, Takes any [`CAT-OBJ`][74bd] and creates a + morphism from that object to [`SO1`][5cfe] (also known as unit). - The formal grammar of [`TERMINAL`][ae41] is + The formal grammar of [`TERMINAL`][874b] is ```lisp (terminal obj) ``` - where [`TERMINAL`][ae41] is the constructor. [`OBJ`][f1e6] is the type of object that - will be mapped to [`SO1`][ebf5], when the morphism is applied onto an + where [`TERMINAL`][874b] is the constructor. [`OBJ`][f1e6] is the type of object that + will be mapped to [`SO1`][5cfe], when the morphism is applied onto an object. Example: @@ -1019,16 +1121,16 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` In the first example, we make a morphism from the corpoduct of - [`SO1`][ebf5] and [`SO1`][ebf5] (essentially [`GEB-BOOL:BOOL`][0ad4]) to - [`SO1`][ebf5]. + [`SO1`][5cfe] and [`SO1`][5cfe] (essentially [`GEB-BOOL:BOOL`][0ad4]) to + [`SO1`][5cfe]. In the third example we can proclaim a constant function by ignoring the input value and returning a morphism from unit to the desired type. The fourth example is taking a [`GEB-BOOL:BOOL`][0ad4] and returning [`GEB-BOOL:TRUE`][f022]. - -- [type] **PAIR** + +- [class] **PAIR** *[\][db35]* Introduces products. Namely Takes two [`CAT-MORPH`][a7af] values. When the `PAIR` morphism is applied on data, these two [`CAT-MORPH`][a7af]'s are @@ -1053,20 +1155,20 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a (<-right so1 geb-bool:bool))) ``` - Here this pair morphism takes the pair `SO1`([`0`][f4ba] [`1`][ebf5]) × [`GEB-BOOL:BOOL`][0ad4], and - projects back the left field `SO1` as the first value of the pair and + Here this pair morphism takes the pair `SO1`([`0`][5cfe] [`1`][f4ba]) × [`GEB-BOOL:BOOL`][0ad4], and + projects back the left field [`SO1`][5cfe] as the first value of the pair and projects back the `GEB-BOOL:BOOL` field as the second values. - -- [type] **DISTRIBUTE** + +- [class] **DISTRIBUTE** *[\][db35]* The distributive law - -- [type] **INJECT-LEFT** + +- [class] **INJECT-LEFT** *[\][db35]* The left injection morphism. Takes two [`CAT-OBJ`][74bd] values. It is - the dual of [`INJECT-RIGHT`][fae9] + the dual of [`INJECT-RIGHT`][e947] The formal grammar is @@ -1090,16 +1192,16 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` - In the second example, we inject a term with the shape `SO1`([`0`][f4ba] [`1`][ebf5]) into a pair - with the shape ([`SO1`][ebf5] × [`GEB-BOOL:BOOL`][0ad4]), then we use [`MCASE`][cd11] to denote a - morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][f4ba] [`1`][ebf5]), then give us True, + In the second example, we inject a term with the shape `SO1`([`0`][5cfe] [`1`][f4ba]) into a pair + with the shape ([`SO1`][5cfe] × [`GEB-BOOL:BOOL`][0ad4]), then we use [`MCASE`][cd11] to denote a + morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][5cfe] [`1`][f4ba]), then give us True, otherwise flip the value of the boolean coming in. - -- [type] **INJECT-RIGHT** + +- [class] **INJECT-RIGHT** *[\][db35]* The right injection morphism. Takes two [`CAT-OBJ`][74bd] values. It is - the dual of [`INJECT-LEFT`][cab9] + the dual of [`INJECT-LEFT`][8387] The formal grammar is @@ -1124,26 +1226,26 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a ``` In the second example, we inject a term with the shape [`GEB-BOOL:BOOL`][0ad4] - into a pair with the shape ([`SO1`][ebf5] × [`GEB-BOOL:BOOL`][0ad4]), then we use - [`MCASE`][cd11] to denote a morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][f4ba] [`1`][ebf5]), + into a pair with the shape ([`SO1`][5cfe] × [`GEB-BOOL:BOOL`][0ad4]), then we use + [`MCASE`][cd11] to denote a morphism saying. [`IF`][684b] the input is of the shape `SO1`([`0`][5cfe] [`1`][f4ba]), then give us True, otherwise flip the value of the boolean coming in. - -- [type] **PROJECT-LEFT** + +- [class] **PROJECT-LEFT** *[\][db35]* - The [`LEFT` PROJECTION][0dcc]. Takes two - [`CAT-MORPH`][a7af] values. When the [`LEFT` PROJECTION][0dcc] morphism is then applied, it grabs the left value of a product, + The [`LEFT` PROJECTION][5ae3]. Takes two + [`CAT-MORPH`][a7af] values. When the [`LEFT` PROJECTION][5ae3] morphism is then applied, it grabs the left value of a product, with the type of the product being determined by the two [`CAT-MORPH`][a7af] values given. - the formal grammar of a [`PROJECT-LEFT`][0dcc] is: + the formal grammar of a [`PROJECT-LEFT`][5ae3] is: ```lisp (<-left mcar mcadr) ``` Where [`<-LEFT`][2882] is the constructor, [`MCAR`][f1ce] is the left type of the - [PRODUCT][e755] and [`MCADR`][cc87] is the right type of the [PRODUCT][e755]. + [PRODUCT][7e58] and [`MCADR`][cc87] is the right type of the [PRODUCT][7e58]. Example: @@ -1155,24 +1257,24 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a In this example, we are getting the left [`GEB-BOOL:BOOL`][0ad4] from a product with the shape - ([`GEB-BOOL:BOOL`][0ad4] [×][77c2] [`SO1`][ebf5] [×][77c2] [`GEB-BOOL:BOOL`][0ad4]) + ([`GEB-BOOL:BOOL`][0ad4] [×][06c6] [`SO1`][5cfe] [×][06c6] [`GEB-BOOL:BOOL`][0ad4]) - -- [type] **PROJECT-RIGHT** + +- [class] **PROJECT-RIGHT** *[\][db35]* - The [`RIGHT` PROJECTION][e65d]. Takes two - [`CAT-MORPH`][a7af] values. When the [`RIGHT` PROJECTION][e65d] morphism is then applied, it grabs the right value of a product, + The [`RIGHT` PROJECTION][06e0]. Takes two + [`CAT-MORPH`][a7af] values. When the [`RIGHT` PROJECTION][06e0] morphism is then applied, it grabs the right value of a product, with the type of the product being determined by the two [`CAT-MORPH`][a7af] values given. - the formal grammar of a [`PROJECT-RIGHT`][e65d] is: + the formal grammar of a [`PROJECT-RIGHT`][06e0] is: ```lisp (<-right mcar mcadr) ``` Where [`<-RIGHT`][0dfe] is the constructor, [`MCAR`][f1ce] is the right type of the - [PRODUCT][e755] and [`MCADR`][cc87] is the right type of the [PRODUCT][e755]. + [PRODUCT][7e58] and [`MCADR`][cc87] is the right type of the [PRODUCT][7e58]. Example: @@ -1185,10 +1287,10 @@ we can view this as automatically lifting a [`SUBSTOBJ`][3173] into a In this example, we are getting the right [`GEB-BOOL:BOOL`][0ad4] from a product with the shape - ([`GEB-BOOL:BOOL`][0ad4] [×][77c2] [`SO1`][ebf5] [×][77c2] [`GEB-BOOL:BOOL`][0ad4]) + ([`GEB-BOOL:BOOL`][0ad4] [×][06c6] [`SO1`][5cfe] [×][06c6] [`GEB-BOOL:BOOL`][0ad4]) - -- [type] **FUNCTOR** + +- [class] **FUNCTOR** *[\][db35]* The [Accessors][cc51] specific to [Subst Morph][d2d1] @@ -1263,8 +1365,55 @@ The [Accessors][cc51] specific to [Subst Morph][d2d1] Right projection (product elimination) + +#### 7.3.3 Realized Subst Objs + +This section covers the [`REALIZED-OBJECT`][73be] type. This +represents a realized [`SUBSTOBJ`][3173] term. + +The [`REALIZED-OBJECT`][73be] is not a real constructor but rather a sum +type for the following type + +```lisp +(deftype realized-object () `(or left right list so1 so0)) +``` + +In ML we would have written something like + +```haskell +type realized-object = so0 + | so1 + | list + | left + | right +``` + + + +- [type] **REALIZED-OBJECT** + + A realized object that can be sent into. + + Lists represent [`PROD`][06c6] in the [``][fb79] category + + [`LEFT`][6444] and [`RIGHT`][c275] represents realized values for [`COPROD`][8be5] + + Lastly [`SO1`][5cfe] and [`SO0`][5c7c] represent the proper class + + +- [class] **LEFT** *[DIRECT-POINTWISE-MIXIN][e2b0]* + + +- [class] **RIGHT** *[DIRECT-POINTWISE-MIXIN][e2b0]* + + +- [function] **LEFT** *OBJ* + + +- [function] **RIGHT** *OBJ* + -### 7.3 Accessors +### 7.4 Accessors ###### \[in package GEB.UTILS\] These functions are generic lenses of the GEB codebase. If a class is @@ -1334,8 +1483,14 @@ likely to be used. They may even augment existing classes. the then branch of the [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + +- [generic-function] **CODE** *OBJ* + + the code of the + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + -### 7.4 Constructors +### 7.5 Constructors ###### \[in package GEB.SPEC\] The API for creating GEB terms. All the functions and variables @@ -1395,12 +1550,77 @@ More Ergonomic API variants for [`*SO0*`][e982] and [`*SO1*`][b960] - [function] **MAKE-FUNCTOR** *&KEY OBJ FUNC* -### 7.5 API +### 7.6 API Various forms and structures built on-top of [Core Category][cb9e] + +- [method] **GAPPLY** *(MORPH \) OBJECT* + + My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for [][7e58], the + OBJECT that I expect is of type [`REALIZED-OBJECT`][73be]. See the + documentation for [`REALIZED-OBJECT`][73be] for the forms it can take. + + Some examples of me are + + ```lisp + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (left so1)) + (right s-1) + GEB> (gapply (comp + (mcase geb-bool:true + geb-bool:not) + (->right so1 geb-bool:bool)) + (right so1)) + (left s-1) + GEB> (gapply geb-bool:and + (list (right so1) + (right so1))) + (right s-1) + GEB> (gapply geb-bool:and + (list (left so1) + (right so1))) + (left s-1) + GEB> (gapply geb-bool:and + (list (right so1) + (left so1))) + (left s-1) + GEB> (gapply geb-bool:and + (list (left so1) + (left so1))) + (left s-1) + ``` + + + +- [method] **GAPPLY** *(MORPH OPAQUE-MORPH) OBJECT* + + My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for a generic [OPAQUE-MOPRH][7e58] + I simply dispatch [`GAPPLY`][bb34] on my interior code + `lisp + GEB> (gapply (comp geb-list:*car* geb-list:*cons*) + (list (right geb-bool:true-obj) (left geb-list:*nil*))) + (right GEB-BOOL:TRUE) + ` + + +- [method] **GAPPLY** *(MORPH OPAQUE) OBJECT* + + My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for a generic [`OPAQUE`][2fc2] I + simply dispatch [`GAPPLY`][bb34] on my interior code, which + is likely just an object + -#### 7.5.1 Booleans +#### 7.6.1 Booleans ###### \[in package GEB-BOOL\] Here we define out the idea of a boolean. It comes naturally from the @@ -1460,25 +1680,85 @@ The functions given work on this. - [symbol-macro] **OR** + +#### 7.6.2 Lists + +###### \[in package GEB-LIST\] +Here we define out the idea of a List. It comes naturally from the +concept of coproducts. Since we lack polymorphism this list is +concrete over [`GEB-BOOL:@GEB-BOOL`][section] In ML syntax it looks like + +```haskell +data List = Nil | Cons Bool List +``` + +We likewise define it with coproducts, with the recursive type being opaque + +```lisp +(defparameter *nil* (so1)) + +(defparameter *cons-type* (reference 'cons)) + +(defparameter *canonical-cons-type* + (opaque 'cons + (prod geb-bool:bool *cons-type*))) + +(defparameter *list* + (coprod *nil* *cons-type*)) +``` + +The functions given work on this. + + +- [variable] **\*NIL\*** *NIL* + + +- [variable] **\*CONS-TYPE\*** *CONS* + + +- [variable] **\*LIST\*** *LIST* + + +- [variable] **\*CAR\*** *CAR* + + +- [variable] **\*CONS\*** *CONS-Μ* + + +- [variable] **\*CDR\*** *CDR* + + +- [symbol-macro] **CONS-\>LIST** + + +- [symbol-macro] **NIL-\>LIST** + + +- [variable] **\*CANONICAL-CONS-TYPE\*** *CONS* + -#### 7.5.2 Translation Functions +#### 7.6.3 Translation Functions ###### \[in package GEB.TRANS\] These cover various conversions from [Subst Morph][d2d1] and [Subst Obj][c1b3] into other categorical data structures. - -- [generic-function] **TO-POLY** *MORPHISM* + +- [method] **TO-POLY** *(OBJ \)* - Turns a [Subst Morph][d2d1] into a [`POLY:POLY`][8bf3] + +- [method] **TO-POLY** *(OBJ \)* - -- [function] **TO-CIRCUIT** *OBJ NAME* + +- [method] **TO-CIRCUIT** *(OBJ \) NAME* Turns a [Subst Morph][d2d1] to a Vamp-IR Term + +- [method] **TO-BITC** *(OBJ \)* + -#### 7.5.3 Utility +#### 7.6.4 Utility ###### \[in package GEB.MAIN\] Various utility functions ontop of [Core Category][cb9e] @@ -1503,12 +1783,12 @@ Various utility functions ontop of [Core Category][cb9e] The constant morphism. - Takes a morphism from [`SO1`][ebf5] to a desired value of type $B$, - along with a [``][8214] that represents the input type say of + Takes a morphism from [`SO1`][5cfe] to a desired value of type $B$, + along with a [``][fb79] that represents the input type say of type $A$, giving us a morphism from $A$ to $B$. Thus if: - `F` : [`SO1`][ebf5] → a, + `F` : [`SO1`][5cfe] → a, `X` : b then: (const f x) : a → b @@ -1519,7 +1799,7 @@ Various utility functions ontop of [Core Category][cb9e] (const f x) : a → b ``` - Further, If the input `F` is an `ALIAS`, then we wrap the output + Further, If the input `F` has an [`ALIAS`][315f], then we wrap the output in a new alias to denote it's a constant version of that value. Example: @@ -1538,7 +1818,7 @@ Various utility functions ontop of [Core Category][cb9e] swap the input [domain][9728] of the given [cat-morph][a7af] In order to swap the [domain][9728] we expect the [cat-morph][a7af] to - be a [`PROD`][77c2] + be a [`PROD`][06c6] Thus if: `(dom morph) ≡ (prod x y)`, for any `x`, `y` [`CAT-OBJ`][74bd] @@ -1572,10 +1852,10 @@ Various utility functions ontop of [Core Category][cb9e] Curries the given object, returns a [cat-morph][a7af] - The [cat-morph][a7af] given must have its [`DOM`][9728] be of a [`PROD`][77c2] type, as `CURRY` + The [cat-morph][a7af] given must have its [`DOM`][9728] be of a [`PROD`][06c6] type, as [`CURRY`][2cbc] invokes the idea of - if f : ([`PROD`][77c2] a b) → c + if f : ([`PROD`][06c6] a b) → c for all `a`, `b`, and `c` being an element of [cat-morph][a7af] @@ -1592,13 +1872,33 @@ Various utility functions ontop of [Core Category][cb9e] In category terms, `a → c^b` is isomorphic to `a → b → c` + +- [function] **COPROD-MOR** *F G* + + Given f : A → B and g : C → D gives appropriate morphism between + [`COPROD`][8be5] objects f x g : A + B → C + D via the unversal property. + That is, the morphism part of the coproduct functor Geb x Geb → Geb + + +- [function] **PROD-MOR** *F G* + + Given f : A → B and g : C → D gives appropriate morphism between + [`PROD`][06c6] objects f x g : A x B → C x D via the unversal property. + This is the morphism part of the product functor Geb x Geb → Geb + + +- [function] **UNCURRY** *Y Z F* + + Given a morphism f : x → z^y and explicitly given y and z variables + produces an uncurried version f' : x × y → z of said morphism + - [generic-function] **TEXT-NAME** *MORPH* Gets the name of the moprhism -### 7.6 Examples +### 7.7 Examples PLACEHOLDER: TO SHOW OTHERS HOW `EXAMPLE`s WORK @@ -1616,15 +1916,97 @@ with GEB: ``` + +## 8 Extension Sets for Categories + +###### \[in package GEB.EXTENSION.SPEC\] +This package contains many extensions one may see over the codebase. + +Each extension adds an unique feature to the categories they are +extending. To learn more, read about the individual extension you are +interested in. + +Common Sub expressions represent repeat logic that can be found +throughout any piece of code + + +- [class] **COMMON-SUB-EXPRESSION** *[DIRECT-POINTWISE-MIXIN][e2b0] [META-MIXIN][4529] [CAT-MORPH][a7af]* + + I represent common sub-expressions found throughout the code. + + I implement a few categorical extensions. I am a valid + [`CAT-MORPH`][a7af] along with fulling the interface for the + GEB.POLY.SPEC:([`0`][7058] [`1`][78ef]) category. + + The name should come from an algorithm that automatically fines common + sub-expressions and places the appropriate names. + + +- [function] **MAKE-COMMON-SUB-EXPRESSION** *&KEY OBJ NAME* + +The Opaque extension lets users write categorical objects and +morphisms where their implementation hide the specifics of what +types they are operating over + + +- [class] **OPAQUE** *[CAT-OBJ][74bd] [META-MIXIN][4529]* + + I represent an object where we want to hide the implementation + details of what kind of [`GEB:SUBSTOBJ`][3173] I am. + + +- [class] **REFERENCE** *[CAT-OBJ][74bd] [CAT-MORPH][a7af] [DIRECT-POINTWISE-MIXIN][e2b0] [META-MIXIN][4529]* + + I represent a reference to an [`OPAQUE`][2fc2] identifier. + + +- [class] **OPAQUE-MORPH** *[CAT-MORPH][a7af] [META-MIXIN][4529]* + + This represents a morphsim where we want to deal with an + [`OPAQUE`][2fc2] that we know intimate details of + + +- [method] **CODE** *(OPAQUE-MORPH OPAQUE-MORPH)* + + the code that represents the underlying morphsism + + +- [method] **DOM** *(OPAQUE-MORPH OPAQUE-MORPH)* + + The dom of the opaque morph + + +- [method] **CODOM** *(OPAQUE-MORPH OPAQUE-MORPH)* + + The codom of the opaque morph + + +- [method] **CODE** *(OPAQUE OPAQUE)* + + +- [method] **NAME** *(OPAQUE OPAQUE)* + + +- [method] **NAME** *(REFERENCE REFERENCE)* + + +- [function] **REFERENCE** *NAME* + + +- [function] **OPAQUE-MORPH** *CODE &KEY (DOM (DOM CODE)) (CODOM (CODOM CODE))* + + +- [function] **OPAQUE** *NAME CODE* + -## 8 The GEB GUI +## 9 The GEB GUI ###### \[in package GEB-GUI\] This section covers the suite of tools that help visualize geb objects and make the system nice to work with -### 8.1 Visualizer +### 9.1 Visualizer The GEB visualizer deals with visualizing any objects found in the [Core Category][cb9e] @@ -1645,20 +2027,20 @@ layout of the term, showing what kind of data Kills all threads and open gui objects created by [`VISUALIZE`][ada5] -#### 8.1.1 Aiding the Visualizer +#### 9.1.1 Aiding the Visualizer One can aid the visualization process a bit, this can be done by -simply playing `GEB:ALIAS` around the object, this will place it +simply placing `ALIAS` around the object, this will place it in a box with a name to better identify it in the graphing procedure. -### 8.2 The GEB Graphizer +### 9.2 The GEB Graphizer ###### \[in package GEB-GUI.GRAPHING\] This section covers the GEB Graph representation -#### 8.2.1 The GEB Graphizer Core +#### 9.2.1 The GEB Graphizer Core ###### \[in package GEB-GUI.CORE\] This section covers the graphing procedure in order to turn a GEB @@ -1672,7 +2054,7 @@ The core types that facilittate the functionality A note is a note about a new node in the graph or a note about a [`NODE`][ff98] which should be merged into an upcoming `NODE`. - An example of a `NODE-NOTE` would be in the case of pair + An example of a [`NODE-NOTE`][c3e8] would be in the case of pair ```lisp (pair g f) @@ -1718,6 +2100,14 @@ The core types that facilittate the functionality particular node. This information is tracked, by storing the object that goes to it in the meta table and recovering the note. + +- [class] **NODE-NOTE** + + +- [class] **SQUASH-NOTE** + + This note should be squashed into another note and or node. + - [function] **MAKE-NOTE** *&REST INITARGS &KEY FROM NOTE VALUE &ALLOW-OTHER-KEYS* @@ -1786,7 +2176,7 @@ The core types that facilittate the functionality Notorizes the node with a prefix appended with the subscripted number -#### 8.2.2 The GEB Graphizer Passes +#### 9.2.2 The GEB Graphizer Passes ###### \[in package GEB-GUI.GRAPHING.PASSES\] This changes how the graph is visualized, simplifying the graph in @@ -1799,324 +2189,1418 @@ ways that are intuitive to the user These simplifications should not change the semantics of the graph, only display it in a more bearable way - -## 9 Polynomial Specification + +## 10 Bits (Boolean Circuit) Specification -###### \[in package GEB.POLY\] -This covers a GEB view of Polynomials. In particular this type will -be used in translating GEB's view of Polynomials into Vampir +###### \[in package GEB.BITC\] +This covers a GEB view of Boolean Circuits. In particular this type will +be used in translating GEB's view of Boolean Circuits into Vampir - -### 9.1 Polynomial Types + +### 10.1 Bits Types -###### \[in package GEB.POLY.SPEC\] -This section covers the types of things one can find in the [`POLY`][8bf3] +###### \[in package GEB.BITC.SPEC\] +This section covers the types of things one can find in the `BIT`s([`0`][6a3c] [`1`][2410]) constructors - -- [type] **POLY** - - -- [type] **\** - - -- [type] **IDENT** - - The Identity Element - - -- [type] **+** + +- [type] **BITC** - -- [type] **\*** + +- [class] **\** *[DIRECT-POINTWISE-MIXIN][e2b0] [CAT-MORPH][a7af]* - -- [type] **/** + +- [class] **COMPOSE** *[\][26d4]* - -- [type] **-** + composes the [`MCAR`][f1ce] and the [`MCADR`][cc87] - -- [type] **MOD** + +- [class] **FORK** *[\][26d4]* - -- [type] **COMPOSE** + Copies the [`MCAR`][f1ce] of length n onto length 2\*n by copying its + inputs (`MCAR`). - -- [type] **IF-ZERO** + +- [class] **PARALLEL** *[\][26d4]* - compare with zero: equal takes first branch; - not-equal takes second branch + ```lisp + (parallel x y) + ``` + + constructs a [`PARALLEL`][46bc] term where the [`MCAR`][f1ce] is `x` and the + [`MCADR`][cc87] is `y`, + + where if + + ``` + x : a → b, y : c → d + ------------------------------- + (parallel x y) : a + c → b + d + ``` + + then the [`PARALLEL`][46bc] will return a function from a and c to b + and d where the [`MCAR`][f1ce] and [`MCADR`][cc87] run on subvectors of the input. - -- [type] **IF-LT** + +- [class] **SWAP** *[\][26d4]* - If the [`MCAR`][f1ce] argument is strictly less than the [`MCADR`][cc87] then the - [`THEN`][bfa9] branch is taken, otherwise the [`ELSE`][365a] branch is taken. + ```lisp + (swap n m) + ``` + + binds the [`MCAR`][f1ce] to n and [`MCADR`][cc87] to m, where if the input + vector is of length `n + m`, then it swaps the bits, algebraically we + view it as + + ```lisp + (swap n m) : #*b₁...bₙbₙ₊₁...bₙ₊ₘ → #*bₙ₊₁...bₘ₊ₙb₁...bₙ + ``` - -### 9.2 Polynomial Constructors -###### \[in package GEB.POLY.SPEC\] -Every accessor for each of the [`CLASS`][7e58]'s found here are from [Accessors][cc51] + +- [class] **ONE** *[\][26d4]* - -- [symbol-macro] **IDENT** + [`ONE`][cf10] represents the map from 0 onto 1 producing a vector + with only 1 in it. - -- [function] **+** *MCAR MCADR &REST ARGS* + +- [class] **ZERO** *[\][26d4]* - Creates a multiway constructor for [+][c144] + [`ZERO`][fa6c] map from 0 onto 1 producing a vector with only 0 in + it. - -- [function] **\*** *MCAR MCADR &REST ARGS* + +- [class] **IDENT** *[\][26d4]* - Creates a multiway constructor for [\*][0ae3] + [`IDENT`][c417] represents the identity - -- [function] **/** *MCAR MCADR &REST ARGS* + +- [class] **DROP** *[\][26d4]* - Creates a multiway constructor for [/][c2f9] + [`DROP`][f130] represents the unique morphism from n to 0. - -- [function] **-** *MCAR MCADR &REST ARGS* + +- [class] **BRANCH** *[\][26d4]* - Creates a multiway constructor for [-][2c5e] + ```lisp + (branch x y) + ``` + + constructs a [`BRANCH`][414c] term where the [`MCAR`][f1ce] is `x` and the + [`MCADR`][cc87] is `y`, + + where if + + ``` + x : a → b, y : a → b + ------------------------------- + (branch x y) : 1+a → b + ``` + + then the [`BRANCH`][1774] will return a function on the type `1 + a`, where the + 1 represents a bit to branch on. If the first bit is `0`, then the + [`MCAR`][f1ce] is ran, however if the bit is `1`, then the [`MCADR`][cc87] is ran. - -- [function] **MOD** *MCAR MCADR* + +### 10.2 Bits (Boolean Circuit) Constructors - `MOD` ARG1 by ARG2 +###### \[in package GEB.BITC.SPEC\] +Every accessor for each of the [`CLASS`][7e58]'s found here are from [Accessors][cc51] - + - [function] **COMPOSE** *MCAR MCADR &REST ARGS* - Creates a multiway constructor for [`COMPOSE`][9162] - - -- [function] **IF-ZERO** *PRED THEN ELSE* + Creates a multiway constructor for [`COMPOSE`][ecb2] - checks if [`PREDICATE`][8da6] is zero then take the [`THEN`][bfa9] branch otherwise the [`ELSE`][365a] branch + +- [function] **FORK** *MCAR* - -- [function] **IF-LT** *MCAR MCADR THEN ELSE* + `FORK` ARG1 - Checks if the [`MCAR`][f1ce] is less than the [`MCADR`][cc87] and chooses the appropriate branch + +- [function] **PARALLEL** *MCAR MCADR &REST ARGS* - -### 9.3 Polynomial Transformations + Creates a multiway constructor for [`PARALLEL`][46bc] -###### \[in package GEB.POLY.TRANS\] -This covers transformation functions from + +- [function] **SWAP** *MCAR MCADR* - -- [generic-function] **TO-VAMPIR** *MORPHISM VALUE* + swap ARG1 and ARG2 - Turns a [`POLY`][8bf3] term into a Vamp-IR term with a given value + +- [symbol-macro] **ONE** - -- [function] **TO-CIRCUIT** *MORPHISM NAME* + +- [symbol-macro] **ZERO** - Turns a [`POLY`][8bf3] term into a Vamp-IR Gate with the given name + +- [function] **IDENT** *MCAR* - -## 10 The Simply Typed Lambda Calculus model + ident ARG1 -###### \[in package GEB.LAMBDA\] -This covers GEB's view on simply typed lambda calculus + +- [function] **DROP** *MCAR* - -### 10.1 Lambda Specification + drop ARG1 -###### \[in package GEB.LAMBDA.SPEC\] -This covers the various the abstract data type that is the simply - typed lambda calculus within GEB. + +- [function] **BRANCH** *MCAR MCADR* -The specification follows from the sum type declaration + branch with ARG1 or ARG2 -```lisp -(defunion stlc - (absurd (value t)) - unit - (left (value t)) - (right (value t)) - (case-on (lty geb.spec:substmorph) - (rty geb.spec:substmorph) - (cod geb.spec:substmorph) - (on t) (left t) (right t)) - (pair (lty geb.spec:substmorph) (rty geb.spec:substmorph) (left t) (right t)) - (fst (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (snd (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (lamb (vty geb.spec:substmorph) (tty geb.spec:substmorph) (value t)) - (app (dom geb.spec:substmorph) (cod geb.spec:substmorph) (func t) (obj t)) - (index (index fixnum))) -``` + +### 10.3 Bits (Boolean Circuit) API +###### \[in package GEB.BITC.MAIN\] +This covers the Bits (Boolean Circuit) API - -- [type] **\** + +- [method] **GAPPLY** *(MORPHISM \) (OBJECT BIT-VECTOR)* - -- [type] **STLC** + My My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for [``][26d4], the + `OBJECT` that I expect is of type [`NUMBER`][7dbb]. [`GAPPLY`][bb34] + reduces down to ordinary common lisp expressions rather straight + forwardly + + ```lisp + ;; figure out the number of bits the function takes + GEB-TEST> (dom (to-bitc geb-bool:and)) + 2 (2 bits, #x2, #o2, #b10) + GEB-TEST> (gapply (to-bitc geb-bool:and) #*11) + #*1 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*10) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*01) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) #*00) + #*0 + ``` - -- [type] **ABSURD** - -- [function] **ABSURD-VALUE** *INSTANCE* + +- [method] **GAPPLY** *(MORPHISM \) (OBJECT LIST)* - -- [type] **UNIT** + I am a helper gapply function, where the second argument for + [``][26d4] is a list. See the docs for the [`BIT-VECTOR`][46ed] version for + the proper one. We do allow sending in a list like so + + ```lisp + ;; figure out the number of bits the function takes + GEB-TEST> (dom (to-bitc geb-bool:and)) + 2 (2 bits, #x2, #o2, #b10) + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 1)) + #*1 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 0)) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 1)) + #*0 + GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 0)) + #*0 + ``` - -- [type] **PAIR** - -- [function] **PAIR-LTY** *INSTANCE* + +- [method] **DOM** *(X \)* - -- [function] **PAIR-RTY** *INSTANCE* + Gives the length of the bit vector the [``][26d4] moprhism takes - -- [function] **PAIR-LEFT** *INSTANCE* + +- [method] **CODOM** *(X \)* - -- [function] **PAIR-RIGHT** *INSTANCE* + Gives the length of the bit vector the [``][26d4] morphism returns - -- [type] **LEFT** + +### 10.4 Bits (Boolean Circuit) Transformations - -- [function] **LEFT-VALUE** *INSTANCE* +###### \[in package GEB.BITC.TRANS\] +This covers transformation functions from - -- [type] **RIGHT** + +- [method] **TO-CIRCUIT** *(MORPHISM \) NAME* - -- [function] **RIGHT-VALUE** *INSTANCE* + Turns a [`BITC`][e017] term into a Vamp-IR Gate with the given name - -- [type] **CASE-ON** + +- [method] **TO-VAMPIR** *(OBJ COMPOSE) VALUES CONSTRAINTS* - -- [function] **CASE-ON-LTY** *INSTANCE* + +- [method] **TO-VAMPIR** *(OBJ FORK) VALUES CONSTRAINTS* - -- [function] **CASE-ON-RTY** *INSTANCE* + Copy input n intput bits into 2\*n output bits - -- [function] **CASE-ON-COD** *INSTANCE* + +- [method] **TO-VAMPIR** *(OBJ PARALLEL) VALUES CONSTRAINTS* - -- [function] **CASE-ON-ON** *INSTANCE* + Take n + m bits, execute car the n bits and cadr on the m bits and + concat the results from car and cadr - -- [function] **CASE-ON-LEFT** *INSTANCE* + +- [method] **TO-VAMPIR** *(OBJ SWAP) VALUES CONSTRAINTS* - -- [function] **CASE-ON-RIGHT** *INSTANCE* + Turn n + m bits into m + n bits by swapping - -- [type] **FST** + +- [method] **TO-VAMPIR** *(OBJ ONE) VALUES CONSTRAINTS* - -- [function] **FST-LTY** *INSTANCE* + Produce a bitvector of length 1 containing 1 - -- [function] **FST-RTY** *INSTANCE* + +- [method] **TO-VAMPIR** *(OBJ ZERO) VALUES CONSTRAINTS* - -- [function] **FST-VALUE** *INSTANCE* + Produce a bitvector of length 1 containing 0 - -- [type] **SND** + +- [method] **TO-VAMPIR** *(OBJ IDENT) VALUES CONSTRAINTS* - -- [function] **SND-LTY** *INSTANCE* + turn n bits into n bits by doing nothing - -- [function] **SND-RTY** *INSTANCE* + +- [method] **TO-VAMPIR** *(OBJ DROP) VALUES CONSTRAINTS* - -- [function] **SND-VALUE** *INSTANCE* + turn n bits into an empty bitvector - -- [type] **LAMB** + +- [method] **TO-VAMPIR** *(OBJ BRANCH) VALUES CONSTRAINTS* - -- [function] **LAMB-VTY** *INSTANCE* + Look at the first bit. + + If its 0, run f on the remaining bits. + + If its 1, run g on the remaining bits. - -- [function] **LAMB-TTY** *INSTANCE* + +## 11 Polynomial Specification - -- [function] **LAMB-VALUE** *INSTANCE* +###### \[in package GEB.POLY\] +This covers a GEB view of Polynomials. In particular this type will +be used in translating GEB's view of Polynomials into Vampir + + +### 11.1 Polynomial Types + +###### \[in package GEB.POLY.SPEC\] +This section covers the types of things one can find in the [`POLY`][8bf3] +constructors + + +- [type] **POLY** + + +- [class] **\** *[GEB.MIXINS:DIRECT-POINTWISE-MIXIN][e2b0]* + + +- [type] **IDENT** + + The Identity Element + + +- [type] **+** + + +- [type] **\*** + + +- [type] **/** + + +- [type] **-** + + +- [type] **MOD** + + +- [type] **COMPOSE** + + +- [type] **IF-ZERO** + + compare with zero: equal takes first branch; + not-equal takes second branch + + +- [type] **IF-LT** + + If the [`MCAR`][f1ce] argument is strictly less than the [`MCADR`][cc87] then the + [`THEN`][bfa9] branch is taken, otherwise the [`ELSE`][365a] branch is taken. + + +### 11.2 Polynomial API + +###### \[in package GEB.POLY.MAIN\] +This covers the polynomial API + + +- [method] **GAPPLY** *(MORPHISM \) OBJECT* + + My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for [`POLY:`][b4a6], the + `OBJECT` that I expect is of type [`NUMBER`][7dbb]. [`GAPPLY`][bb34] reduces down to + ordinary common lisp expressions rather straight forwardly + + Some examples of me are + + ```lisp + (in-package :geb.poly) + + POLY> (gapply (if-zero (- ident ident 1) 10 ident) 5) + 5 (3 bits, #x5, #o5, #b101) + + POLY> (gapply (if-zero (- ident ident) 10 ident) 5) + 10 (4 bits, #xA, #o12, #b1010) + + POLY> (gapply (- (* 2 ident ident) (* ident ident)) 5) + 25 (5 bits, #x19, #o31, #b11001) + ``` + + + +- [method] **GAPPLY** *(MORPHISM INTEGER) OBJECT* + + My main documentation can be found on [`GAPPLY`][bb34] + + I am the [`GAPPLY`][bb34] for [`INTEGER`][ac8a]s, the + `OBJECT` that I expect is of type [`NUMBER`][7dbb]. I simply return myself. + + Some examples of me are + + ```lisp + (in-package :geb.poly) + + POLY> (gapply 10 5) + 10 (4 bits, #xA, #o12, #b1010) + ``` + + + +### 11.3 Polynomial Constructors + +###### \[in package GEB.POLY.SPEC\] +Every accessor for each of the [`CLASS`][7e58]'s found here are from [Accessors][cc51] + + +- [symbol-macro] **IDENT** + + +- [function] **+** *MCAR MCADR &REST ARGS* + + Creates a multiway constructor for [+][c144] + + +- [function] **\*** *MCAR MCADR &REST ARGS* + + Creates a multiway constructor for [\*][0ae3] + + +- [function] **/** *MCAR MCADR &REST ARGS* + + Creates a multiway constructor for [/][c2f9] + + +- [function] **-** *MCAR MCADR &REST ARGS* + + Creates a multiway constructor for [-][2c5e] + + +- [function] **MOD** *MCAR MCADR* + + `MOD` ARG1 by ARG2 + + +- [function] **COMPOSE** *MCAR MCADR &REST ARGS* + + Creates a multiway constructor for [`COMPOSE`][9162] + + +- [function] **IF-ZERO** *PRED THEN ELSE* + + checks if [`PREDICATE`][8da6] is zero then take the [`THEN`][bfa9] branch otherwise + the [`ELSE`][365a] branch + + +- [function] **IF-LT** *MCAR MCADR THEN ELSE* + + Checks if the [`MCAR`][f1ce] is less than the [`MCADR`][cc87] and chooses the appropriate branch + + +### 11.4 Polynomial Transformations + +###### \[in package GEB.POLY.TRANS\] +This covers transformation functions from + + +- [method] **TO-CIRCUIT** *(MORPHISM \) NAME* + + Turns a [`POLY`][8bf3] term into a Vamp-IR Gate with the given name + + +- [method] **TO-VAMPIR** *(OBJ INTEGER) VALUE LET-VARS* + + Numbers act like a constant function, ignoring input + + +- [method] **TO-VAMPIR** *(OBJ IDENT) VALUE LET-VARS* + + Identity acts as the identity function + + +- [method] **TO-VAMPIR** *(OBJ +) VALUE LET-VARS* + + Propagates the value and adds them + + +- [method] **TO-VAMPIR** *(OBJ \*) VALUE LET-VARS* + + Propagates the value and times them + + +- [method] **TO-VAMPIR** *(OBJ -) VALUE LET-VARS* + + Propagates the value and subtracts them + + +- [method] **TO-VAMPIR** *(OBJ /) VALUE LET-VARS* + + +- [method] **TO-VAMPIR** *(OBJ COMPOSE) VALUE LET-VARS* + + +- [method] **TO-VAMPIR** *(OBJ IF-ZERO) VALUE LET-VARS* + + The [`PREDICATE`][8da6] that comes in must be 1 or 0 for the formula to work out. + + +- [method] **TO-VAMPIR** *(OBJ IF-LT) VALUE LET-VARS* + + +- [method] **TO-VAMPIR** *(OBJ MOD) VALUE LET-VARS* + + +## 12 The Simply Typed Lambda Calculus model + +###### \[in package GEB.LAMBDA\] +This covers GEB's view on simply typed lambda calculus + +This serves as a useful frontend for those wishing to write a compiler +to GEB and do not wish to target the categorical model. + +If one is targeting their compiler to the frontend, then the following +code should be useful for you. + +```lisp +(in-package :geb.lambda.main) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (index 0)) + :id) +(def id x1 = { + (x1) + };) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit))))) + :not) +(def not x1 = { + (((1 - x1) * 1) + (x1 * 0), ((1 - x1) * 1) + (x1 * 0)) + };) + +MAIN> (to-circuit (lamb (list geb-bool:bool) + (left so1 (right so1 (index 0)))) :foo) +(def foo x1 = { + (0, 1, x1) + };) +``` + +For testing purposes, it may be useful to go to the `BITC` backend and +run our interpreter + +```lisp +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*1) +#*00 +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*0) +#*11 +``` + + + +### 12.1 Lambda Specification + +###### \[in package GEB.LAMBDA.SPEC\] +This covers the various the abstract data type that is the simply +typed lambda calculus within GEB. The class presents untyped [`STLC`][e373] terms. + + +- [type] **STLC** + + Type of untyped terms of [`STLC`][e373]. Each class of a term has a slot for a type, + which can be filled by auxillary functions or by user. Types are + represented as [SUBSTOBJ][3173]. + + +- [class] **\** *[DIRECT-POINTWISE-MIXIN][e2b0] [META-MIXIN][4529] [CAT-OBJ][74bd]* + + Class of untyped terms of simply typed lambda claculus. Given our + presentation, we look at the latter as a type theory spanned by empty, + unit types as well as coproduct, product, and function types. + + +- [class] **ABSURD** *[\][b36a]* + + The [`ABSURD`][4710] term provides an element of an arbitrary type + given a term of the empty type, denoted by [SO0][5c7c]. + The formal grammar of [`ABSURD`][4710] is + + ```lisp + (absurd tcod term) + ``` + + where we possibly can include type information by + + ```lisp + (absurd tcod term :ttype ttype) + ``` + + The intended semantics are: [`TCOD`][70c0] is a type whose term we want to + get (and hence a [SUBSTOBJ][3173]) and [`TERM`][0171] is a term + of the empty type (and hence an [`STLC`][e373]. + + This corresponds to the elimination rule of the empty type. Namely, + given + $$\Gamma \vdash \text{tcod : Type}$$ and + $$\Gamma \vdash \text{term : so0}$$ one deduces + $$\Gamma \vdash \text{(absurd tcod term) : tcod}$$ + + +- [class] **UNIT** *[\][b36a]* + + The unique term of the unit type, the latter represented by + [SO1][5cfe]. The formal grammar of [`UNIT`][0433] is + + ```lisp + (unit) + ``` + + where we can optionally include type information by + + ```lisp + (unit :ttype ttype) + ``` + + Clearly the type of [`UNIT`][0433] is [SO1][5cfe] but here + we provide all terms untyped. + + This grammar corresponds to the introduction rule of the unit type. Namely + $$\Gamma \dashv \text{(unit) : so1}$$ + + +- [class] **LEFT** *[\][b36a]* + + Term of a coproduct type gotten by injecting into the left type of the coproduct. The formal grammar of + [`LEFT`][56b3] is + + ```lisp + (left rty term) + ``` + + where we can include optional type information by + + ```lisp + (left rty term :ttype ttype) + ``` + + The indended semantics are as follows: [`RTY`][abea] should + be a type (and hence a [SUBSTOBJ][3173]) and specify the + right part of the coproduct of the type [`TTYPE`][134c] of + the entire term. The term (and hence an [`STLC`][e373]) we are injecting + is [`TERM`][0171]. + + This corresponds to the introduction rule of the coproduct type. Namely, given + $$\Gamma \dashv \text{(ttype term) : Type}$$ and + $$\Gamma \dashv \text{rty : Type}$$ + with + $$\Gamma \dashv \text{term : (ttype term)}$$ we deduce + $$\Gamma \dashv \text{(left rty term) : (coprod (ttype term) rty)}$$ + + +- [class] **RIGHT** *[\][b36a]* + + Term of a coproduct type gotten by injecting into the right type of + the coproduct. The formal grammar of [`RIGHT`][48fc] is + + ```lisp + (right lty term) + ``` + + where we can include optional type information by + + ```lisp + (right lty term :ttype ttype) + ``` + + The indended semantics are as follows: [`LTY`][15a3] should be a type (and + hence a [SUBSTOBJ][3173]) and specify the left part of + the coproduct of the type [`TTYPE`][134c] of the entire term. The term (and + hence an [`STLC`][e373]) we are injecting is [`TERM`][0171]. + + This corresponds to the introduction rule of the coproduct type. Namely, given + $$\Gamma \dashv \text{(ttype term) : Type}$$ and + $$\Gamma \dashv \text{lty : Type}$$ + with + $$\Gamma \dashv \text{term : (ttype term)}$$ we deduce + $$\Gamma \dashv \text{(right lty term) : (coprod lty (ttype term))}$$ + + +- [class] **CASE-ON** *[\][b36a]* + + A term of an arbutrary type provided by casing on a coproduct term. The + formal grammar of [`CASE-ON`][3f9d] is + + ```lisp + (case-on on ltm rtm) + ``` + + where we can possibly include type information by + + ```lisp + (case-on on ltm rtm :ttype ttype) + ``` + + The intended semantics are as follows: [`ON`][7c57] is a term (and hence an + [`STLC`][e373]) of a coproduct type, and [`LTM`][fcda] and [`RTM`][d762] terms (hence + also [`STLC`][e373]) of the same type in the context of - appropriately + - (mcar (ttype on)) and (mcadr (ttype on)). + + This corresponds to the elimination rule of the coprodut type. Namely, given + $$\Gamma \vdash \text{on : (coprod (mcar (ttype on)) (mcadr (ttype on)))}$$ + and + $$\text{(mcar (ttype on))} , \Gamma \vdash \text{ltm : (ttype ltm)}$$ + , $$\text{(mcadr (ttype on))} , \Gamma \vdash \text{rtm : (ttype ltm)}$$ + we get + $$\Gamma \vdash \text{(case-on on ltm rtm) : (ttype ltm)}$$ + Note that in practice we append contexts on the left as computation of + [`INDEX`][5b8b] is done from the left. Otherwise, the rules are the same as in + usual type theory if context was read from right to left. + + +- [class] **PAIR** *[\][b36a]* + + A term of the product type gotten by pairing a terms of a left and right + parts of the product. The formal grammar of [`PAIR`][5dae] is + + ```lisp + (pair ltm rtm) + ``` + + where we can possibly include type information by + + ```lisp + (pair ltm rtm :ttype ttype) + ``` + + The intended semantics are as follows: [`LTM`][fcda] is a term (and hence an + [`STLC`][e373]) of a left part of the product type whose terms we are + producing. [`RTM`][d762] is a term (hence also [`STLC`][e373])of the right part + of the product. + + The grammar corresponds to the introdcution rule of the pair type. Given + $$\Gamma \vdash \text{ltm : (mcar (ttype (pair ltm rtm)))}$$ and + $$\Gamma \vdash \text{rtm : (mcadr (ttype (pair ltm rtm)))}$$ we have + $$\Gamma \vdash \text{(pair ltm rtm) : (ttype (pair ltm rtm))}$$ + + +- [class] **FST** *[\][b36a]* + + The first projection of a term of a product type. + The formal grammar of [`FST`][b4a5] is: + + ```lisp + (fst term) + ``` + + where we can possibly include type information by + + ```lisp + (fst term :ttype ttype) + ``` + + The indended semantics are as follows: [`TERM`][0171] is a + term (and hence an [`STLC`][e373]) of a product type, to whose left part + we are projecting to. + + This corresponds to the first projection function gotten by induction + on a term of a product type. + + +- [class] **SND** *[\][b36a]* + + The second projection of a term of a product type. + The formal grammar of [`SND`][0424] is: + + ```lisp + (snd term) + ``` + + where we can possibly include type information by + + ```lisp + (snd term :ttype ttype) + ``` + + The indended semantics are as follows: [`TERM`][0171] is a + term (and hence an [`STLC`][e373]) of a product type, to whose right + part we are projecting to. + + This corresponds to the second projection function gotten by induction + on a term of a product type. + + +- [class] **LAMB** *[\][b36a]* + + A term of a function type gotten by providing a term in the codomain + of the function type by assuming one is given variables in the + specified list of types. [`LAMB`][8cde] takes in the [`TDOM`][2c8c] + accessor a list of types - and hence of [SUBSTOBJ][7e58] - and in the + [`TERM`][0171] a term - and hence an [`STLC`][e373]. The formal grammar + of [`LAMB`][8cde] is: + + ```lisp + (lamb tdom term) + ``` + + where we can possibly include type information by + + ```lisp + (lamb tdom term :ttype ttype) + ``` + + The intended semnatics are: [`TDOM`][2c8c] is a list of types (and + hence a list of [SUBSTOBJ][3173]) whose iterative product of + components form the domain of the function type. [`TERM`][0171] + is a term (and hence an [`STLC`][e373]) of the codomain of the function type + gotten in the context to whom we append the list of the domains. + + For a list of length 1, corresponds to the introduction rule of the function + type. Namely, given + $$\Gamma \vdash \text{tdom : Type}$$ and + $$\Gamma, \text{tdom} \vdash \text{term : (ttype term)}$$ we have + $$\Gamma \vdash \text{(lamb tdom term) : (so-hom-obj tdom (ttype term))}$$ + + For a list of length n, this coreesponds to the iterated lambda type, e.g. + + ```lisp + (lamb (list so1 so0) (index 0)) + ``` + + is a term of + + ```lisp + (so-hom-obj (prod so1 so0) so0) + ``` + + or equivalently + + ```lisp + (so-hom-obj so1 (so-hom-obj so0 so0)) + ``` + + due to Geb's computational definition of the function type. + + Note that [`INDEX`][5b8b] 0 in the above code is of type [SO1][7e58]. + So that after annotating the term, one gets + + ```lisp + LAMBDA> (ttype (term (lamb (list so1 so0)) (index 0))) + s-1 + ``` + + So the counting of indeces starts with the leftmost argument for + computational reasons. In practice, typing of [`LAMB`][8cde] corresponds with + taking a list of arguments provided to a lambda term, making it a context + in that order and then counting the index of the varibale. Type-theoretically, + + $$\Gamma \vdash \lambda \Delta (index i)$$ + $$\Delta, \Gamma \vdash (index i)$$ + + So that by the operational semantics of [`INDEX`][5b8b], the type of (index i) + in the above context will be the i'th element of the Delta context counted from + the left. Note that in practice we append contexts on the left as computation of + [`INDEX`][5b8b] is done from the left. Otherwise, the rules are the same as in + usual type theory if context was read from right to left. + + +- [class] **APP** *[\][b36a]* + + A term of an arbitrary type gotten by applying a function of an iterated + function type with a corresponding codomain iteratively to terms in the + domains. [`APP`][04f2] takes as argument for the [`FUN`][cccf] accessor + a function - and hence an [`STLC`][e373] - whose function type has domain an + iterated [`GEB:PROD`][06c6] of [SUBSTOBJ][clas] and for the [`TERM`][0171] + a list of terms - and hence of [`STLC`][e373] - matching the types of the + product. The formal grammar of [`APP`][04f2] is + + ```lisp + (app fun term) + ``` + + where we can possibly include type information by + + ```lisp + (app fun term :ttype ttype) + ``` + + The intended semantics are as follows: + [`FUN`][cccf] is a term (and hence an [`STLC`][e373]) of a coproduct + type - say of (so-hom-obj (ttype term) y) - and [`TERM`][0171] is a + list of terms (hence also of [`STLC`][e373]) with nth term in the list having the + n-th part of the function type. + + For a one-argument term list, this corresponds to the elimination rule of the + function type. Given + $$\Gamma \vdash \text{fun : (so-hom-obj (ttype term) y)}$$ and + $$\Gamma \vdash \text{term : (ttype term)}$$ we get + $$\Gamma \vdash \text{(app fun term) : y}$$ + + For several arguments, this corresponds to successive function application. + Using currying, this corresponds to, given + + ``` + G ⊢ (so-hom-obj (A₁ × ··· × Aₙ₋₁) Aₙ) + G ⊢ f : (so-hom-obj (A₁ × ··· × Aₙ₋₁) + G ⊢ tᵢ : Aᵢ + ``` + + then for each `i` less than `n` gets us + + ```lisp + G ⊢ (app f t₁ ··· tₙ₋₁) : Aₙ + ``` + + Note again that i'th term should correspond to the ith element of the product + in the codomain counted from the left. + + +- [class] **INDEX** *[\][b36a]* + + The variable term of an arbitrary type in a context. The formal + grammar of [`INDEX`][5b8b] is + + ```lisp + (index pos) + ``` + + where we can possibly include type information by + + ```lisp + (index pos :ttype ttype) + ``` + + The intended semantics are as follows: [`POS`][3f85] is a + natural number indicating the position of a type in a context. + + This corresponds to the variable rule. Namely given a context + $$\Gamma\_1 , \ldots , \Gamma\_{pos} , \ldots , \Gamma\_k $$ we have + + $$\Gamma\_1 , \ldots , \Gamma\_k \vdash \text{(index pos) :} \Gamma\_{pos}$$ + + Note that we add contexts on the left rather than on the right contra classical + type-theoretic notation. + + +- [function] **ABSURD** *TCOD TERM &KEY (TTYPE NIL)* + + +- [function] **UNIT** *&KEY (TTYPE NIL)* + + +- [function] **LEFT** *RTY TERM &KEY (TTYPE NIL)* + + +- [function] **RIGHT** *LTY TERM &KEY (TTYPE NIL)* + + +- [function] **CASE-ON** *ON LTM RTM &KEY (TTYPE NIL)* + + +- [function] **PAIR** *LTM RTM &KEY (TTYPE NIL)* + + +- [function] **FST** *TERM &KEY (TTYPE NIL)* + + +- [function] **SND** *TERM &KEY (TTYPE NIL)* + + +- [function] **LAMB** *TDOM TERM &KEY (TTYPE NIL)* + + +- [function] **APP** *FUN TERM &KEY (TTYPE NIL)* + + +- [function] **INDEX** *POS &KEY (TTYPE NIL)* + +Accessors of [`ABSURD`][4710] + + +- [method] **TCOD** *(ABSURD ABSURD)* + + An arbitrary type + + +- [method] **TERM** *(ABSURD ABSURD)* + + A term of the empty type + + +- [method] **TTYPE** *(ABSURD ABSURD)* + +Accessors of [`UNIT`][0433] + + +- [method] **TTYPE** *(UNIT UNIT)* + +Accessors of [`LEFT`][56b3] + + +- [method] **RTY** *(LEFT LEFT)* + + Right argument of coproduct type + + +- [method] **TERM** *(LEFT LEFT)* + + Term of the left argument of coproduct type + + +- [method] **TTYPE** *(LEFT LEFT)* + +Accessors of [`RIGHT`][48fc] + + +- [method] **LTY** *(RIGHT RIGHT)* + + Left argument of coproduct type + + +- [method] **TERM** *(RIGHT RIGHT)* + + Term of the right argument of coproduct type + + +- [method] **TTYPE** *(RIGHT RIGHT)* + +Accessors of [`CASE-ON`][3f9d] + + +- [method] **ON** *(CASE-ON CASE-ON)* + + Term of coproduct type + + +- [method] **LTM** *(CASE-ON CASE-ON)* + + Term in context of left argument of coproduct type + + +- [method] **RTM** *(CASE-ON CASE-ON)* + + Term in context of right argument of coproduct type + + +- [method] **TTYPE** *(CASE-ON CASE-ON)* + +Accessors of [`PAIR`][5dae] + + +- [method] **LTM** *(PAIR PAIR)* - -- [type] **APP** + Term of left argument of the product type - -- [function] **APP-DOM** *INSTANCE* + +- [method] **RTM** *(PAIR PAIR)* - -- [function] **APP-COD** *INSTANCE* + Term of right argument of the product type - -- [function] **APP-FUNC** *INSTANCE* + +- [method] **TTYPE** *(PAIR PAIR)* - -- [function] **APP-OBJ** *INSTANCE* +Accessors of [`FST`][b4a5] - -- [type] **INDEX** + +- [method] **TERM** *(FST FST)* - -- [function] **INDEX-INDEX** *INSTANCE* + Term of product type - -- [function] **TYPED** *V TYP* + +- [method] **TTYPE** *(FST FST)* - Puts together the type declaration with the value itself for lambda terms +Accessors of [`SND`][0424] - -- [function] **TYPED-STLC-TYPE** *INSTANCE* + +- [method] **TERM** *(SND SND)* - -- [function] **TYPED-STLC-VALUE** *INSTANCE* + Term of product type + + +- [method] **TTYPE** *(SND SND)* + +Accessors of [`LAMB`][8cde] + + +- [method] **TDOM** *(LAMB LAMB)* + + Domain of the lambda term + + +- [method] **TERM** *(LAMB LAMB)* + + Term of the codomain mapped to given a variable of tdom + + +- [method] **TTYPE** *(LAMB LAMB)* + +Accessors of [`APP`][04f2] + + +- [method] **FUN** *(APP APP)* + + Term of exponential type + + +- [method] **TERM** *(APP APP)* + + List of Terms of the domain + + +- [method] **TTYPE** *(APP APP)* + +Accessors of [`INDEX`][5b8b] + + +- [method] **POS** *(INDEX INDEX)* + + Position of type + + +- [method] **TTYPE** *(INDEX INDEX)* + + +- [generic-function] **TCOD** *OBJ* + + +- [generic-function] **TDOM** *OBJ* + + +- [generic-function] **TERM** *OBJ* + + +- [generic-function] **RTY** *OBJ* + + +- [generic-function] **LTY** *OBJ* + + +- [generic-function] **LTM** *OBJ* + + +- [generic-function] **RTM** *OBJ* + + +- [generic-function] **ON** *OBJ* + + +- [generic-function] **FUN** *OBJ* + + +- [generic-function] **POS** *OBJ* + + +- [generic-function] **TTYPE** *OBJ* -### 10.2 Main functionality +### 12.2 Main functionality ###### \[in package GEB.LAMBDA.MAIN\] This covers the main API for the [`STLC`][e373] module + +- [generic-function] **ANN-TERM1** *CTX TTERM* + + Given a list of [`SUBSTOBJ`][3173] objects with + [`SO-HOM-OBJ`][07dd] occurences replaced by [`FUN-TYPE`][8dcc] + and an [`STLC`][e373] similarly replacing type occurences of the hom object + to [`FUN-TYPE`][8dcc], provides the [`TTYPE`][134c] accessor to all + subterms as well as the term itself, using [`FUN-TYPE`][8dcc]. Once again, + note that it is important for the context and term to be giving as + per above description. While not always, not doing so result in an error upon + evaluation. As an example of a valid entry we have + + ```lisp + (ann-term1 (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) + ``` + + while + + ```lisp + (ann-term1 (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) + ``` + + produces an error trying to use [`HOM-COD`][b324]. This warning applies to other + functions taking in context and terms below as well. + + Moreover, note that for terms whose typing needs addition of new context + we append contexts on the left rather than on the right contra usual type + theoretic notation for the convenience of computation. That means, e.g. that + asking for a type of a lambda term as below produces: + + ```lisp + LAMBDA> (ttype (term (ann-term1 (lambda (list so1 so0) (index 0))))) + s-1 + ``` + + as we count indeces from the left of the context while appending new types to + the context on the left as well. For more info check [`LAMB`][8cde] + + +- [function] **HOM-COD** *CTX F* + + Given a context of [`SUBSTOBJ`][3173] with occurences of + [`SO-HOM-OBJ`][07dd] replaced by [`FUN-TYPE`][8dcc], and similarly + an [`STLC`][e373] term of the stand-in for the hom object, produces the stand-in + to the codomain. + + +- [function] **INDEX-CHECK** *I CTX* + + Given an natural number `I` and a context, checks that the context is of + length at least `I` and then produces the Ith entry of the context counted + from the left starting with 0. + + +- [function] **FUN-TO-HOM** *T1* + + Given a [`SUBSTOBJ`][3173] whose subobjects might have a + [`FUN-TYPE`][8dcc] occurence replaces all occurences of [`FUN-TYPE`][8dcc] with a + suitable [`SO-HOM-OBJ`][07dd], hence giving a pure + [`SUBSTOBJ`][3173] + + ```lisp + LAMBDA> (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)) + (× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) + ``` + + + +- [function] **ANN-TERM2** *TTERM* + + Given an [`STLC`][e373] term with a [`TTYPE`][134c] accessor from + [`ANN-TERM1`][ac2d] - i.e. including possible [`FUN-TYPE`][8dcc] + occurences - re-annotates the term and its subterms with actual + [`SUBSTOBJ`][3173] objects. + + +- [function] **ANNOTATED-TERM** *CTX TERM* + + Given a context consisting of a list of [`SUBSTOBJ`][3173] + with occurences of [`SO-HOM-OBJ`][07dd] replaced by + [`FUN-TYPE`][8dcc] and an [`STLC`][e373] term with similarly replaced occurences + of [`SO-HOM-OBJ`][07dd], provides an [`STLC`][e373] with all + subterms typed, i.e. providing the [`TTYPE`][134c] accessor, + which is a pure [`SUBSTOBJ`][3173] + + +- [function] **TYPE-OF-TERM-W-FUN** *CTX TTERM* + + Given a context consisting of a list of [`SUBSTOBJ`][3173] with + occurences of [`SO-HOM-OBJ`][07dd] replaced by [`FUN-TYPE`][8dcc] + and an [`STLC`][e373] term with similarly replaced occurences of + [`SO-HOM-OBJ`][07dd], gives out a type of the whole term with + occurences of [`SO-HOM-OBJ`][07dd] replaced by [`FUN-TYPE`][8dcc]. + + +- [function] **TYPE-OF-TERM** *CTX TTERM* + + Given a context consisting of a list of [`SUBSTOBJ`][3173] with + occurences of [`SO-HOM-OBJ`][07dd] replaced by [`FUN-TYPE`][8dcc] + and an [`STLC`][e373] term with similarly replaced occurences of + [`SO-HOM-OBJ`][07dd], provides the type of the whole term, + which is a pure [`SUBSTOBJ`][3173]. + + +- [generic-function] **WELL-DEFP** *CTX TTERM* + + Given a context consisting of a list of [`SUBSTOBJ`][3173] + with occurences of [`SO-HOM-OBJ`][07dd] replaced by + [`FUN-TYPE`][8dcc] and an [`STLC`][e373] term with similarly replaced + occurences of [`SO-HOM-OBJ`][07dd], checks that the term + is well-defined in the context based on structural rules of simply + typed lambda calculus. returns the t if it is, otherwise returning + nil + + +- [class] **FUN-TYPE** *[DIRECT-POINTWISE-MIXIN][e2b0] [CAT-OBJ][74bd]* + + Stand-in for the [`SO-HOM-OBJ`][07dd] object. It does not have + any computational properties and can be seen as just a function of two arguments + with accessors [`MCAR`][f1ce] to the first argument and + [`MCADR`][cc87] to the second argument. There is an evident canonical + way to associate [`FUN-TYPE`][8dcc] and [`SO-HOM-OBJ`][07dd] + pointwise. + + +- [function] **FUN-TYPE** *MCAR MCADR* + + +- [method] **MCAR** *(FUN-TYPE FUN-TYPE)* + + +- [method] **MCADR** *(FUN-TYPE FUN-TYPE)* + + +- [generic-function] **MCAR** *OBJ* + + Can be seen as calling [`CAR`][8c99] on a generic CLOS + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + + +- [generic-function] **MCADR** *OBJ* + + like [`MCAR`][f1ce] but for the [`CADR`][74ab] + -### 10.3 Transition Functions +### 12.3 Transition Functions ###### \[in package GEB.LAMBDA.TRANS\] These functions deal with transforming the data structure to other data types - -- [generic-function] **COMPILE-CHECKED-TERM** *CONTEXT TYPE TERM* +One important note about the lambda conversions is that all +transition functions except [`TO-CAT`][d243] do not take a context. + +Thus if the [``][b36a] term contains free variables, then call +[`TO-CAT`][d243] and give it the desired context before calling +any other transition functions + + +- [method] **TO-CAT** *CONTEXT (TTERM \)* + + Compiles a checked term in an appropriate context into the + morphism of the GEB category. In detail, it takes a context and a term with + following restrictions: Terms come from [`STLC`][e373] with occurences of + [`SO-HOM-OBJ`][07dd] replaced by [`FUN-TYPE`][8dcc] and should + come without the slow of [`TTYPE`][134c] accessor filled for any of + the subterms. Context should be a list of [`SUBSTOBJ`][3173] with + the caveat that instead of [`SO-HOM-OBJ`][07dd] we ought to use + [`FUN-TYPE`][8dcc], a stand-in for the internal hom object with explicit + accessors to the domain and the codomain. Once again, note that it is important + for the context and term to be giving as per above description. While not + always, not doing so result in an error upon evaluation. As an example of a + valid entry we have + + ```lisp + (to-cat (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) + ``` + + while + + ```lisp + (to-cat (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) + ``` + + produces an error. Error of such kind mind pop up both on the level of evaluating + [`WELL-DEFP`][4fcb] and [`ANN-TERM1`][ac2d]. + + Moreover, note that for terms whose typing needs addition of new context + we append contexts on the left rather than on the right contra usual type + theoretic notation for the convenience of computation. That means, e.g. that + asking for a type of a lambda term as below produces: + + ```lisp + LAMBDA> (ttype (term (ann-term1 nil (lamb (list so1 so0) (index 0))))) + s-1 + ``` + + as we count indeces from the left of the context while appending new types to + the context on the left as well. For more info check [`LAMB`][8cde] + + +- [method] **TO-POLY** *(OBJ \)* + + I convert a lambda term into a [`GEB.POLY.SPEC:POLY`][8bf3] term + + Note that [``][b36a] terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call [to-cat][d243] before + calling me - Compiles a checked term into SubstMorph category + +- [method] **TO-BITC** *(OBJ \)* - -- [function] **TO-POLY** *CONTEXT TYPE OBJ* + I convert a lambda term into a [`GEB.BITC.SPEC:BITC`][e017] term + + Note that [``][b36a] terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call [to-cat][d243] before + calling me - -- [function] **TO-CIRCUIT** *CONTEXT TYPE OBJ NAME* + +- [method] **TO-CIRCUIT** *(OBJ \) NAME* + + I convert a lambda term into a vampir term + + Note that [``][b36a] terms with free variables require a context, + and we do not supply them here to conform to the standard interface + + If you want to give a context, please call [to-cat][d243] before + calling me -#### 10.3.1 Utility Functionality +#### 12.3.1 Utility Functionality These are utility functions relating to translating lambda terms to other types - [function] **STLC-CTX-TO-MU** *CONTEXT* - Converts a generic [(CODE )][78ef] context into a [`SUBSTMORPH`][57dc] + Converts a generic [(CODE )][78ef] context into a + [`SUBSTMORPH`][57dc]. Note that usually contexts can be interpreted + in a category as a $Sigma$-type$, which in a non-dependent setting gives us a + usual [`PROD`][06c6] + + ```lisp + LAMBDA> (stlc-ctx-to-mu (list so1 (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)))) + (× s-1 + (× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) + s-1) + ``` + - [function] **SO-HOM** *DOM COD* @@ -2124,7 +3608,7 @@ These are utility functions relating to translating lambda terms to other types Computes the hom-object of two [`SUBSTMORPH`][57dc]s -## 11 Mixins +## 13 Mixins ###### \[in package GEB.MIXINS\] Various [mixins](https://en.wikipedia.org/wiki/Mixin) of the @@ -2132,7 +3616,7 @@ project. Overall all these offer various services to the rest of the project -### 11.1 Pointwise Mixins +### 13.1 Pointwise Mixins Here we provide various mixins that deal with classes in a pointwise manner. Normally, objects can not be compared in a pointwise manner, @@ -2161,7 +3645,7 @@ in our class Further all `DIRECT-POINTWISE-MIXIN`'s are [`POINTWISE-MIXIN`][445d]'s -### 11.2 Pointwise API +### 13.2 Pointwise API These are the general API functions on any class that have the [`POINTWISE-MIXIN`][445d] service. @@ -2193,8 +3677,14 @@ traversal as `LIST`([`0`][592c] [`1`][98f9])'s are Works like `C2MOP:COMPUTE-SLOTS` however on the object rather than the class + +- [function] **MAP-POINTWISE** *FUNCTION OBJ* + + +- [function] **REDUCE-POINTWISE** *FUNCTION OBJ INITIAL* + -### 11.3 Mixins Examples +### 13.3 Mixins Examples Let's see some example uses of [`POINTWISE-MIXIN`][445d]: @@ -2209,7 +3699,7 @@ Let's see some example uses of [`POINTWISE-MIXIN`][445d]: -### 11.4 Metadata Mixin +### 13.4 Metadata Mixin Metadata is a form of meta information about a particular object. Having metadata about an object may be useful if the goal @@ -2249,7 +3739,7 @@ it like an ordinary hashtable look past weak pointers if they exist -#### 11.4.1 Performance +#### 13.4.1 Performance The data stored is at the [`CLASS`][7e58] level. So having your type take the [`META-MIXIN`][4529] does interfere with the cache. @@ -2293,7 +3783,7 @@ storage inside metadata be separated into volatile and stable storage. -## 12 Geb Utilities +## 14 Geb Utilities ###### \[in package GEB.UTILS\] The Utilities package provides general utility functionality that is @@ -2390,6 +3880,18 @@ used throughout the GEB codebase - [function] **SHALLOW-COPY-OBJECT** *ORIGINAL* + +- [generic-function] **COPY-INSTANCE** *OBJECT &REST INITARGS &KEY &ALLOW-OTHER-KEYS* + + Makes and returns a shallow copy of `OBJECT`. + + An uninitialized object of the same class as `OBJECT` is allocated by + calling [`ALLOCATE-INSTANCE`][a859]. For all slots returned by + CLASS-SLOTS, the returned object has the + same slot values and slot-unbound status as `OBJECT`. + + [`REINITIALIZE-INSTANCE`][1456] is called to update the copy with `INITARGS`. + - [macro] **MAKE-PATTERN** *OBJECT-NAME &REST CONSTRUCTOR-NAMES* @@ -2427,8 +3929,19 @@ used throughout the GEB codebase Turns an [`INTEGER`][ac8a] into a subscripted [`STRING`][4267] + +- [function] **APPLY-N** *TIMES F INITIAL* + + Applies a function, f, n `TIMES` to the `INITIAL` values + + ```lisp + GEB> (apply-n 10 #'1+ 0) + 10 (4 bits, #xA, #o12, #b1010) + ``` + + -### 12.1 Accessors +### 14.1 Accessors These functions are generic lenses of the GEB codebase. If a class is defined, where the names are not known, then these accessors are @@ -2497,8 +4010,14 @@ likely to be used. They may even augment existing classes. the then branch of the [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + +- [generic-function] **CODE** *OBJ* + + the code of the + [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object) + -## 13 Testing +## 15 Testing ###### \[in package GEB-TEST\] We use [parachute](https://quickref.common-lisp.net/parachute.html) @@ -2539,71 +4058,116 @@ features and how to better lay out future tests simply run this function to generate a fresh one + [0171]: #x-28GEB-2ELAMBDA-2ESPEC-3ATERM-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:TERM GENERIC-FUNCTION" + [0251]: #x-28GEB-2EPOLY-2EMAIN-3A-40POLY-API-20MGL-PAX-3ASECTION-29 "Polynomial API" + [0424]: #x-28GEB-2ELAMBDA-2ESPEC-3ASND-20CLASS-29 "GEB.LAMBDA.SPEC:SND CLASS" + [0433]: #x-28GEB-2ELAMBDA-2ESPEC-3AUNIT-20CLASS-29 "GEB.LAMBDA.SPEC:UNIT CLASS" + [04f2]: #x-28GEB-2ELAMBDA-2ESPEC-3AAPP-20CLASS-29 "GEB.LAMBDA.SPEC:APP CLASS" [0609]: #x-28GEB-2ELAMBDA-2ETRANS-3A-40UTILITY-20MGL-PAX-3ASECTION-29 "Utility Functionality" + [06c6]: #x-28GEB-2ESPEC-3APROD-20CLASS-29 "GEB.SPEC:PROD CLASS" + [06e0]: #x-28GEB-2ESPEC-3APROJECT-RIGHT-20CLASS-29 "GEB.SPEC:PROJECT-RIGHT CLASS" + [07dd]: #x-28GEB-2EMAIN-3ASO-HOM-OBJ-20FUNCTION-29 "GEB.MAIN:SO-HOM-OBJ FUNCTION" [0ad4]: #x-28GEB-BOOL-3ABOOL-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB-BOOL:BOOL MGL-PAX:SYMBOL-MACRO" [0ae3]: #x-28GEB-2EPOLY-2ESPEC-3A-2A-20TYPE-29 "GEB.POLY.SPEC:* TYPE" - [0dcc]: #x-28GEB-2ESPEC-3APROJECT-LEFT-20TYPE-29 "GEB.SPEC:PROJECT-LEFT TYPE" [0dfe]: #x-28GEB-2ESPEC-3A-3C-RIGHT-20FUNCTION-29 "GEB.SPEC:<-RIGHT FUNCTION" [0e00]: #x-28GEB-DOCS-2FDOCS-3A-40YONEDA-LEMMA-20MGL-PAX-3ASECTION-29 "The Yoneda Lemma" + [0efa]: #x-28GEB-2EEXTENSION-2ESPEC-3A-40GEB-EXTENSIONS-20MGL-PAX-3ASECTION-29 "Extension Sets for Categories" [0f3e]: #x-28GEB-2EPOLY-2ETRANS-3A-40POLY-TRANS-20MGL-PAX-3ASECTION-29 "Polynomial Transformations" + [134c]: #x-28GEB-2ELAMBDA-2ESPEC-3ATTYPE-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:TTYPE GENERIC-FUNCTION" + [1456]: http://www.lispworks.com/documentation/HyperSpec/Body/f_reinit.htm "REINITIALIZE-INSTANCE FUNCTION" + [15a3]: #x-28GEB-2ELAMBDA-2ESPEC-3ALTY-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:LTY GENERIC-FUNCTION" + [1774]: #x-28GEB-2EBITC-2ESPEC-3ABRANCH-20FUNCTION-29 "GEB.BITC.SPEC:BRANCH FUNCTION" [1791]: http://www.lispworks.com/documentation/HyperSpec/Body/f_car_c.htm "CADDDR FUNCTION" [1b98]: #x-28GEB-GUI-2EGRAPHING-3A-40GRAPHING-MANUAL-20MGL-PAX-3ASECTION-29 "The GEB Graphizer" - [1f3a]: #x-28GEB-2ESPEC-3ASO0-20TYPE-29 "GEB.SPEC:SO0 TYPE" + [1c91]: #x-28GEB-LIST-3A-40GEB-LIST-20MGL-PAX-3ASECTION-29 "Lists" [1fbc]: #x-28GEB-GUI-2ECORE-3ACHILDREN-20GENERIC-FUNCTION-29 "GEB-GUI.CORE:CHILDREN GENERIC-FUNCTION" + [2172]: #x-28GEB-2EBITC-2ESPEC-3A-40BITC-20MGL-PAX-3ASECTION-29 "Bits Types" [2276]: #x-28GEB-2EUTILS-3ASUBCLASS-RESPONSIBILITY-20FUNCTION-29 "GEB.UTILS:SUBCLASS-RESPONSIBILITY FUNCTION" + [2410]: http://www.lispworks.com/documentation/HyperSpec/Body/t_bit.htm "BIT TYPE" [2570]: http://www.lispworks.com/documentation/HyperSpec/Body/f_car_c.htm "CDR FUNCTION" [25f0]: #x-28GEB-DOCS-2FDOCS-3A-40GLOSSARY-20MGL-PAX-3ASECTION-29 "Glossary" + [26d4]: #x-28GEB-2EBITC-2ESPEC-3A-3CBITC-3E-20CLASS-29 "GEB.BITC.SPEC: CLASS" [2882]: #x-28GEB-2ESPEC-3A-3C-LEFT-20FUNCTION-29 "GEB.SPEC:<-LEFT FUNCTION" [29b7]: #x-28GEB-DOCS-2FDOCS-3A-40AGDA-20MGL-PAX-3ASECTION-29 "Geb's Agda Code" [2ad4]: #x-28GEB-2ESPEC-3A-40GEB-CONSTRUCTORS-20MGL-PAX-3ASECTION-29 "Constructors" [2c5e]: #x-28GEB-2EPOLY-2ESPEC-3A--20TYPE-29 "GEB.POLY.SPEC:- TYPE" + [2c8c]: #x-28GEB-2ELAMBDA-2ESPEC-3ATDOM-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:TDOM GENERIC-FUNCTION" [2cbc]: #x-28GEB-2EMAIN-3ACURRY-20FUNCTION-29 "GEB.MAIN:CURRY FUNCTION" + [2eb9]: #x-28GEB-2EGENERICS-3ATO-POLY-20GENERIC-FUNCTION-29 "GEB.GENERICS:TO-POLY GENERIC-FUNCTION" + [2ebc]: #x-28GEB-2EBITC-2ETRANS-3A-40BITC-TRANS-20MGL-PAX-3ASECTION-29 "Bits (Boolean Circuit) Transformations" + [2fc2]: #x-28GEB-2EEXTENSION-2ESPEC-3AOPAQUE-20CLASS-29 "GEB.EXTENSION.SPEC:OPAQUE CLASS" [2fcf]: #x-28GEB-2EMIXINS-3A-40POINTWISE-API-20MGL-PAX-3ASECTION-29 "Pointwise API" + [315f]: #x-28GEB-2ESPEC-3AALIAS-20MGL-PAX-3AMACRO-29 "GEB.SPEC:ALIAS MGL-PAX:MACRO" [3173]: #x-28GEB-2ESPEC-3ASUBSTOBJ-20TYPE-29 "GEB.SPEC:SUBSTOBJ TYPE" [31c5]: #x-28GEB-BOOL-3AFALSE-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB-BOOL:FALSE MGL-PAX:SYMBOL-MACRO" [34d0]: #x-28GEB-2ELAMBDA-2ESPEC-3A-40LAMBDA-SPECS-20MGL-PAX-3ASECTION-29 "Lambda Specification" [365a]: #x-28GEB-2EUTILS-3AELSE-20GENERIC-FUNCTION-29 "GEB.UTILS:ELSE GENERIC-FUNCTION" [3686]: #x-28GEB-DOCS-2FDOCS-3A-40ORIGINAL-EFFORTS-20MGL-PAX-3ASECTION-29 "Original Efforts" [399c]: #x-28GEB-BOOL-3A-40GEB-BOOL-20MGL-PAX-3ASECTION-29 "Booleans" - [3bc6]: #x-28GEB-2ESPEC-3APAIR-20TYPE-29 "GEB.SPEC:PAIR TYPE" [3d47]: #x-28GEB-DOCS-2FDOCS-3A-40GETTING-STARTED-20MGL-PAX-3ASECTION-29 "Getting Started" + [3f85]: #x-28GEB-2ELAMBDA-2ESPEC-3APOS-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:POS GENERIC-FUNCTION" + [3f9d]: #x-28GEB-2ELAMBDA-2ESPEC-3ACASE-ON-20CLASS-29 "GEB.LAMBDA.SPEC:CASE-ON CLASS" [4044]: #x-28GEB-DOCS-2FDOCS-3A-40COVERAGE-20MGL-PAX-3ASECTION-29 "code coverage" + [414c]: #x-28GEB-2EBITC-2ESPEC-3ABRANCH-20CLASS-29 "GEB.BITC.SPEC:BRANCH CLASS" [417f]: #x-28GEB-TEST-3ACODE-COVERAGE-20FUNCTION-29 "GEB-TEST:CODE-COVERAGE FUNCTION" [4267]: http://www.lispworks.com/documentation/HyperSpec/Body/t_string.htm "STRING TYPE" [42d7]: http://www.lispworks.com/documentation/HyperSpec/Body/m_defpkg.htm "DEFPACKAGE MGL-PAX:MACRO" [445d]: #x-28GEB-2EMIXINS-3APOINTWISE-MIXIN-20CLASS-29 "GEB.MIXINS:POINTWISE-MIXIN CLASS" [4529]: #x-28GEB-2EMIXINS-3AMETA-MIXIN-20CLASS-29 "GEB.MIXINS:META-MIXIN CLASS" [455b]: #x-28GEB-2EMIXINS-3A-40MIXIN-PERFORMANCE-20MGL-PAX-3ASECTION-29 "Performance" + [4659]: #x-28GEB-2EBITC-2EMAIN-3A-40BITC-API-20MGL-PAX-3ASECTION-29 "Bits (Boolean Circuit) API" + [46bc]: #x-28GEB-2EBITC-2ESPEC-3APARALLEL-20CLASS-29 "GEB.BITC.SPEC:PARALLEL CLASS" + [46ed]: http://www.lispworks.com/documentation/HyperSpec/Body/t_bt_vec.htm "BIT-VECTOR TYPE" + [4710]: #x-28GEB-2ELAMBDA-2ESPEC-3AABSURD-20CLASS-29 "GEB.LAMBDA.SPEC:ABSURD CLASS" [4850]: http://www.lispworks.com/documentation/HyperSpec/Body/t_kwd.htm "KEYWORD TYPE" + [48fc]: #x-28GEB-2ELAMBDA-2ESPEC-3ARIGHT-20CLASS-29 "GEB.LAMBDA.SPEC:RIGHT CLASS" [4938]: #x-28GEB-2EMIXINS-3A-40MIXIN-EXAMPLES-20MGL-PAX-3ASECTION-29 "Mixins Examples" [49d4]: #x-28GEB-2EMAIN-3A-40GEB-UTILITY-20MGL-PAX-3ASECTION-29 "Utility" [4a87]: #x-28GEB-DOCS-2FDOCS-3A-40OPEN-TYPE-20MGL-PAX-3AGLOSSARY-TERM-29 "GEB-DOCS/DOCS:@OPEN-TYPE MGL-PAX:GLOSSARY-TERM" + [4fcb]: #x-28GEB-2ELAMBDA-2EMAIN-3AWELL-DEFP-20GENERIC-FUNCTION-29 "GEB.LAMBDA.MAIN:WELL-DEFP GENERIC-FUNCTION" [4ffa]: #x-28GEB-2EUTILS-3A-40GEB-UTILS-MANUAL-20MGL-PAX-3ASECTION-29 "Geb Utilities" + [56b3]: #x-28GEB-2ELAMBDA-2ESPEC-3ALEFT-20CLASS-29 "GEB.LAMBDA.SPEC:LEFT CLASS" [57dc]: #x-28GEB-2ESPEC-3ASUBSTMORPH-20TYPE-29 "GEB.SPEC:SUBSTMORPH TYPE" [58a9]: #x-28GEB-2EMIXINS-3ATO-POINTWISE-LIST-20GENERIC-FUNCTION-29 "GEB.MIXINS:TO-POINTWISE-LIST GENERIC-FUNCTION" [592c]: http://www.lispworks.com/documentation/HyperSpec/Body/f_list_.htm "LIST FUNCTION" - [59dd]: #x-28GEB-2ESPEC-3ACASE-20TYPE-29 "GEB.SPEC:CASE TYPE" + [5ae3]: #x-28GEB-2ESPEC-3APROJECT-LEFT-20CLASS-29 "GEB.SPEC:PROJECT-LEFT CLASS" + [5b8b]: #x-28GEB-2ELAMBDA-2ESPEC-3AINDEX-20CLASS-29 "GEB.LAMBDA.SPEC:INDEX CLASS" + [5c7c]: #x-28GEB-2ESPEC-3ASO0-20CLASS-29 "GEB.SPEC:SO0 CLASS" + [5cfe]: #x-28GEB-2ESPEC-3ASO1-20CLASS-29 "GEB.SPEC:SO1 CLASS" + [5d7c]: #x-28GEB-2ESPEC-3ACASE-20CLASS-29 "GEB.SPEC:CASE CLASS" + [5dae]: #x-28GEB-2ELAMBDA-2ESPEC-3APAIR-20CLASS-29 "GEB.LAMBDA.SPEC:PAIR CLASS" [603e]: #x-28GEB-GUI-3A-40VISAULIZER-AID-20MGL-PAX-3ASECTION-29 "Aiding the Visualizer" [6228]: #x-28GEB-3A-40GEB-API-20MGL-PAX-3ASECTION-29 "API" - [642a]: #x-28GEB-2ETRANS-3ATO-POLY-20GENERIC-FUNCTION-29 "GEB.TRANS:TO-POLY GENERIC-FUNCTION" + [6444]: #x-28GEB-2ESPEC-3ALEFT-20CLASS-29 "GEB.SPEC:LEFT CLASS" [684b]: http://www.lispworks.com/documentation/HyperSpec/Body/s_if.htm "IF MGL-PAX:MACRO" + [6a3c]: http://www.lispworks.com/documentation/HyperSpec/Body/f_bt_sb.htm "BIT FUNCTION" + [6b63]: #x-28GEB-2EBITC-3A-40BITC-MANUAL-20MGL-PAX-3ASECTION-29 "Bits (Boolean Circuit) Specification" [6f67]: #x-28GEB-GUI-3A-40GEB-GUI-MANUAL-20MGL-PAX-3ASECTION-29 "The GEB GUI" + [7058]: http://www.lispworks.com/documentation/HyperSpec/Body/v_nil.htm "NIL MGL-PAX:CONSTANT" [7088]: #x-28GEB-2ESPEC-3ASO0-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB.SPEC:SO0 MGL-PAX:SYMBOL-MACRO" + [70c0]: #x-28GEB-2ELAMBDA-2ESPEC-3ATCOD-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:TCOD GENERIC-FUNCTION" [71e9]: #x-28GEB-GUI-2ECORE-3A-40GRAPHING-CORE-20MGL-PAX-3ASECTION-29 "The GEB Graphizer Core" [723a]: #x-28GEB-2EMIXINS-3A-40MIXINS-20MGL-PAX-3ASECTION-29 "Mixins" + [73be]: #x-28GEB-2ESPEC-3AREALIZED-OBJECT-20TYPE-29 "GEB.SPEC:REALIZED-OBJECT TYPE" [74ab]: http://www.lispworks.com/documentation/HyperSpec/Body/f_car_c.htm "CADR FUNCTION" [74bd]: #x-28GEB-2EMIXINS-3ACAT-OBJ-20CLASS-29 "GEB.MIXINS:CAT-OBJ CLASS" - [77c2]: #x-28GEB-2ESPEC-3APROD-20TYPE-29 "GEB.SPEC:PROD TYPE" [78ef]: http://www.lispworks.com/documentation/HyperSpec/Body/t_nil.htm "NIL TYPE" + [7c57]: #x-28GEB-2ELAMBDA-2ESPEC-3AON-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:ON GENERIC-FUNCTION" + [7dbb]: http://www.lispworks.com/documentation/HyperSpec/Body/t_number.htm "NUMBER TYPE" [7e58]: http://www.lispworks.com/documentation/HyperSpec/Body/t_class.htm "CLASS CLASS" [7f9f]: http://www.lispworks.com/documentation/HyperSpec/Body/t_symbol.htm "SYMBOL TYPE" - [8214]: #x-28GEB-2ESPEC-3A-3CSUBSTOBJ-3E-20TYPE-29 "GEB.SPEC: TYPE" [8311]: #x-28GEB-DOCS-2FDOCS-3A-40IDRIS-20MGL-PAX-3ASECTION-29 "Geb's Idris Code" + [8387]: #x-28GEB-2ESPEC-3AINJECT-LEFT-20CLASS-29 "GEB.SPEC:INJECT-LEFT CLASS" + [874b]: #x-28GEB-2ESPEC-3ATERMINAL-20CLASS-29 "GEB.SPEC:TERMINAL CLASS" [8932]: #x-28GEB-DOCS-2FDOCS-3A-40CLOSED-TYPE-20MGL-PAX-3AGLOSSARY-TERM-29 "GEB-DOCS/DOCS:@CLOSED-TYPE MGL-PAX:GLOSSARY-TERM" [8bb8]: http://www.lispworks.com/documentation/HyperSpec/Body/f_car_c.htm "CADDR FUNCTION" + [8be5]: #x-28GEB-2ESPEC-3ACOPROD-20CLASS-29 "GEB.SPEC:COPROD CLASS" [8bf3]: #x-28GEB-2EPOLY-2ESPEC-3APOLY-20TYPE-29 "GEB.POLY.SPEC:POLY TYPE" [8c99]: http://www.lispworks.com/documentation/HyperSpec/Body/f_car_c.htm "CAR FUNCTION" + [8cde]: #x-28GEB-2ELAMBDA-2ESPEC-3ALAMB-20CLASS-29 "GEB.LAMBDA.SPEC:LAMB CLASS" [8da6]: #x-28GEB-2EUTILS-3APREDICATE-20GENERIC-FUNCTION-29 "GEB.UTILS:PREDICATE GENERIC-FUNCTION" + [8dcc]: #x-28GEB-2ELAMBDA-2EMAIN-3AFUN-TYPE-20CLASS-29 "GEB.LAMBDA.MAIN:FUN-TYPE CLASS" + [8e11]: #x-28GEB-2ESPEC-3AINIT-20CLASS-29 "GEB.SPEC:INIT CLASS" [8eb0]: #x-28GEB-2EENTRY-3A-40GEB-ENTRY-20MGL-PAX-3ASECTION-29 "Geb as a binary" [8fa5]: #x-28GEB-DOCS-2FDOCS-3A-40INSTALLATION-20MGL-PAX-3ASECTION-29 "installation" [9162]: #x-28GEB-2EPOLY-2ESPEC-3ACOMPOSE-20TYPE-29 "GEB.POLY.SPEC:COMPOSE TYPE" @@ -2612,7 +4176,6 @@ features and how to better lay out future tests [94a8]: #x-28GEB-2EPOLY-3A-40POLY-MANUAL-20MGL-PAX-3ASECTION-29 "Polynomial Specification" [96d0]: http://www.lispworks.com/documentation/HyperSpec/Body/f_equal.htm "EQUAL FUNCTION" [9728]: #x-28GEB-2EMIXINS-3ADOM-20GENERIC-FUNCTION-29 "GEB.MIXINS:DOM GENERIC-FUNCTION" - [97fb]: #x-28GEB-2ESPEC-3A-3CSUBSTMORPH-3E-20TYPE-29 "GEB.SPEC: TYPE" [98f9]: http://www.lispworks.com/documentation/HyperSpec/Body/t_list.htm "LIST TYPE" [9bc5]: #x-28GEB-DOCS-2FDOCS-3A-40LINKS-20MGL-PAX-3ASECTION-29 "Links" [9bcb]: #x-28GEB-TEST-3A-40GEB-TEST-MANUAL-20MGL-PAX-3ASECTION-29 "Testing" @@ -2623,19 +4186,28 @@ features and how to better lay out future tests [a7af]: #x-28GEB-2EMIXINS-3ACAT-MORPH-20CLASS-29 "GEB.MIXINS:CAT-MORPH CLASS" [a7d5]: #x-28GEB-DOCS-2FDOCS-3A-40LOADING-20MGL-PAX-3ASECTION-29 "loading" [a802]: http://www.lispworks.com/documentation/HyperSpec/Body/t_std_ob.htm "STANDARD-OBJECT TYPE" + [a84b]: #x-28GEB-2EGENERICS-3A-40GENERICS-20MGL-PAX-3ASECTION-29 "Geneircs" + [a859]: http://www.lispworks.com/documentation/HyperSpec/Body/f_alloca.htm "ALLOCATE-INSTANCE FUNCTION" [a920]: #x-28GEB-DOCS-2FDOCS-3A-40OPEN-CLOSED-20MGL-PAX-3ASECTION-29 "Open Types versus Closed Types" [a981]: http://www.lispworks.com/documentation/HyperSpec/Body/m_defmet.htm "DEFMETHOD MGL-PAX:MACRO" + [abea]: #x-28GEB-2ELAMBDA-2ESPEC-3ARTY-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:RTY GENERIC-FUNCTION" + [ac2d]: #x-28GEB-2ELAMBDA-2EMAIN-3AANN-TERM1-20GENERIC-FUNCTION-29 "GEB.LAMBDA.MAIN:ANN-TERM1 GENERIC-FUNCTION" [ac8a]: http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm "INTEGER TYPE" [ada5]: #x-28GEB-GUI-3AVISUALIZE-20FUNCTION-29 "GEB-GUI:VISUALIZE FUNCTION" [ada9]: #x-28GEB-DOCS-2FDOCS-3A-40MORPHISMS-20MGL-PAX-3ASECTION-29 "Morphisms" - [ae41]: #x-28GEB-2ESPEC-3ATERMINAL-20TYPE-29 "GEB.SPEC:TERMINAL TYPE" [af14]: #x-28GEB-2EUTILS-3AMCDR-20GENERIC-FUNCTION-29 "GEB.UTILS:MCDR GENERIC-FUNCTION" + [b0d9]: #x-28GEB-2EGENERICS-3ATO-CIRCUIT-20GENERIC-FUNCTION-29 "GEB.GENERICS:TO-CIRCUIT GENERIC-FUNCTION" + [b324]: #x-28GEB-2ELAMBDA-2EMAIN-3AHOM-COD-20FUNCTION-29 "GEB.LAMBDA.MAIN:HOM-COD FUNCTION" + [b36a]: #x-28GEB-2ELAMBDA-2ESPEC-3A-3CSTLC-3E-20CLASS-29 "GEB.LAMBDA.SPEC: CLASS" + [b4a5]: #x-28GEB-2ELAMBDA-2ESPEC-3AFST-20CLASS-29 "GEB.LAMBDA.SPEC:FST CLASS" + [b4a6]: #x-28GEB-2EPOLY-2ESPEC-3A-3CPOLY-3E-20CLASS-29 "GEB.POLY.SPEC: CLASS" [b76d]: #x-28GEB-2EPOLY-2ESPEC-3A-40POLY-CONSTRUCTORS-20MGL-PAX-3ASECTION-29 "Polynomial Constructors" [b79a]: #x-28GEB-2ETRANS-3A-40GEB-TRANSLATION-20MGL-PAX-3ASECTION-29 "Translation Functions" [b960]: #x-28GEB-2ESPEC-3A-2ASO1-2A-20VARIABLE-29 "GEB.SPEC:*SO1* VARIABLE" [b9c1]: http://www.lispworks.com/documentation/HyperSpec/Body/t_seq.htm "SEQUENCE TYPE" [b9f3]: #x-28GEB-DOCS-2FDOCS-3A-40IDIOMS-20MGL-PAX-3ASECTION-29 "Project Idioms and Conventions" [ba44]: #x-28GEB-2ESPEC-3A--3ERIGHT-20FUNCTION-29 "GEB.SPEC:->RIGHT FUNCTION" + [bb34]: #x-28GEB-2EGENERICS-3AGAPPLY-20GENERIC-FUNCTION-29 "GEB.GENERICS:GAPPLY GENERIC-FUNCTION" [bd81]: #x-28GEB-2EPOLY-2ESPEC-3A-40POLY-20MGL-PAX-3ASECTION-29 "Polynomial Types" [bf07]: http://www.lispworks.com/documentation/HyperSpec/Body/f_export.htm "EXPORT FUNCTION" [bfa9]: #x-28GEB-2EUTILS-3ATHEN-20GENERIC-FUNCTION-29 "GEB.UTILS:THEN GENERIC-FUNCTION" @@ -2643,43 +4215,55 @@ features and how to better lay out future tests [c144]: #x-28GEB-2EPOLY-2ESPEC-3A-2B-20TYPE-29 "GEB.POLY.SPEC:+ TYPE" [c1b3]: #x-28GEB-2ESPEC-3A-40GEB-SUBSTMU-20MGL-PAX-3ASECTION-29 "Subst Obj" [c1fb]: #x-28GEB-3A-40GEB-20MGL-PAX-3ASECTION-29 "The Geb Model" + [c275]: #x-28GEB-2ESPEC-3ARIGHT-20CLASS-29 "GEB.SPEC:RIGHT CLASS" [c2e9]: #x-28GEB-DOCS-2FDOCS-3A-40MODEL-20MGL-PAX-3ASECTION-29 "Categorical Model" [c2f9]: #x-28GEB-2EPOLY-2ESPEC-3A-2F-20TYPE-29 "GEB.POLY.SPEC:/ TYPE" + [c3e8]: #x-28GEB-GUI-2ECORE-3ANODE-NOTE-20CLASS-29 "GEB-GUI.CORE:NODE-NOTE CLASS" + [c417]: #x-28GEB-2EBITC-2ESPEC-3AIDENT-20FUNCTION-29 "GEB.BITC.SPEC:IDENT FUNCTION" [c6cf]: #x-28GEB-GUI-3A-40GEB-VISUALIZER-20MGL-PAX-3ASECTION-29 "Visualizer" [c721]: http://www.lispworks.com/documentation/HyperSpec/Body/f_equalp.htm "EQUALP FUNCTION" [c767]: http://www.lispworks.com/documentation/HyperSpec/Body/s_the.htm "THE MGL-PAX:MACRO" - [cab9]: #x-28GEB-2ESPEC-3AINJECT-LEFT-20TYPE-29 "GEB.SPEC:INJECT-LEFT TYPE" [cb9e]: #x-28GEB-2ESPEC-3A-40GEB-CATEGORIES-20MGL-PAX-3ASECTION-29 "Core Category" [cc51]: #x-28GEB-2EUTILS-3A-40GEB-ACCESSORS-20MGL-PAX-3ASECTION-29 "Accessors" [cc87]: #x-28GEB-2EUTILS-3AMCADR-20GENERIC-FUNCTION-29 "GEB.UTILS:MCADR GENERIC-FUNCTION" + [cccf]: #x-28GEB-2ELAMBDA-2ESPEC-3AFUN-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:FUN GENERIC-FUNCTION" [cd11]: #x-28GEB-2ESPEC-3AMCASE-20FUNCTION-29 "GEB.SPEC:MCASE FUNCTION" + [ce5b]: #x-28GEB-2ESPEC-3ACOMP-20CLASS-29 "GEB.SPEC:COMP CLASS" [ceb9]: http://www.lispworks.com/documentation/HyperSpec/Body/t_fixnum.htm "FIXNUM TYPE" + [cf10]: #x-28GEB-2EBITC-2ESPEC-3AONE-20CLASS-29 "GEB.BITC.SPEC:ONE CLASS" + [d243]: #x-28GEB-2EGENERICS-3ATO-CAT-20GENERIC-FUNCTION-29 "GEB.GENERICS:TO-CAT GENERIC-FUNCTION" [d2d1]: #x-28GEB-2ESPEC-3A-40GEB-SUBSTMORPH-20MGL-PAX-3ASECTION-29 "Subst Morph" [d2d5]: #x-28GEB-2ELAMBDA-2EMAIN-3A-40LAMBDA-API-20MGL-PAX-3ASECTION-29 "Main functionality" [d5d3]: #x-28GEB-2EMIXINS-3A-40POINTWISE-20MGL-PAX-3ASECTION-29 "Pointwise Mixins" + [d762]: #x-28GEB-2ELAMBDA-2ESPEC-3ARTM-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:RTM GENERIC-FUNCTION" [d908]: http://www.lispworks.com/documentation/HyperSpec/Body/f_typep.htm "TYPEP FUNCTION" + [db35]: #x-28GEB-2ESPEC-3A-3CSUBSTMORPH-3E-20CLASS-29 "GEB.SPEC: CLASS" [db8f]: #x-28GEB-2ELAMBDA-3A-40STLC-20MGL-PAX-3ASECTION-29 "The Simply Typed Lambda Calculus model" [dbe7]: #x-28GEB-DOCS-2FDOCS-3A-40OBJECTS-20MGL-PAX-3ASECTION-29 "Objects" + [dca9]: #x-28GEB-2ESPEC-3A-40GEB-REALIZED-20MGL-PAX-3ASECTION-29 "Realized Subst Objs" + [dfa2]: #x-28GEB-2ESPEC-3APAIR-20CLASS-29 "GEB.SPEC:PAIR CLASS" + [e017]: #x-28GEB-2EBITC-2ESPEC-3ABITC-20TYPE-29 "GEB.BITC.SPEC:BITC TYPE" [e2af]: #x-28GEB-2ESPEC-3A--3ELEFT-20FUNCTION-29 "GEB.SPEC:->LEFT FUNCTION" + [e2b0]: #x-28GEB-2EMIXINS-3ADIRECT-POINTWISE-MIXIN-20CLASS-29 "GEB.MIXINS:DIRECT-POINTWISE-MIXIN CLASS" [e373]: #x-28GEB-2ELAMBDA-2ESPEC-3ASTLC-20TYPE-29 "GEB.LAMBDA.SPEC:STLC TYPE" [e3e4]: #x-28GEB-2ELAMBDA-2ETRANS-3A-40STLC-CONVERSION-20MGL-PAX-3ASECTION-29 "Transition Functions" [e429]: #x-28GEB-GUI-2EGRAPHING-2EPASSES-3A-40PASS-MANUAL-20MGL-PAX-3ASECTION-29 "The GEB Graphizer Passes" - [e65d]: #x-28GEB-2ESPEC-3APROJECT-RIGHT-20TYPE-29 "GEB.SPEC:PROJECT-RIGHT TYPE" - [e755]: http://www.lispworks.com/documentation/HyperSpec/Body/d_type.htm "TYPE DECLARATION" [e91b]: #x-28GEB-2EMIXINS-3A-40MIXINS-CAT-20MGL-PAX-3ASECTION-29 "The Categorical Interface" + [e947]: #x-28GEB-2ESPEC-3AINJECT-RIGHT-20CLASS-29 "GEB.SPEC:INJECT-RIGHT CLASS" [e982]: #x-28GEB-2ESPEC-3A-2ASO0-2A-20VARIABLE-29 "GEB.SPEC:*SO0* VARIABLE" - [ebf5]: #x-28GEB-2ESPEC-3ASO1-20TYPE-29 "GEB.SPEC:SO1 TYPE" + [ecb2]: #x-28GEB-2EBITC-2ESPEC-3ACOMPOSE-20CLASS-29 "GEB.BITC.SPEC:COMPOSE CLASS" [ecc6]: #x-28GEB-DOCS-2FDOCS-3A-40CLOS-20MGL-PAX-3AGLOSSARY-TERM-29 "GEB-DOCS/DOCS:@CLOS MGL-PAX:GLOSSARY-TERM" [ef6e]: #x-28GEB-GUI-2ECORE-3ANOTE-20TYPE-29 "GEB-GUI.CORE:NOTE TYPE" [f022]: #x-28GEB-BOOL-3ATRUE-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB-BOOL:TRUE MGL-PAX:SYMBOL-MACRO" + [f130]: #x-28GEB-2EBITC-2ESPEC-3ADROP-20FUNCTION-29 "GEB.BITC.SPEC:DROP FUNCTION" [f1ce]: #x-28GEB-2EUTILS-3AMCAR-20GENERIC-FUNCTION-29 "GEB.UTILS:MCAR GENERIC-FUNCTION" [f1e6]: #x-28GEB-2EUTILS-3AOBJ-20GENERIC-FUNCTION-29 "GEB.UTILS:OBJ GENERIC-FUNCTION" [f4ba]: #x-28GEB-2ESPEC-3ASO1-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB.SPEC:SO1 MGL-PAX:SYMBOL-MACRO" [f766]: http://www.lispworks.com/documentation/HyperSpec/Body/f_load.htm "LOAD FUNCTION" - [f899]: #x-28GEB-2ESPEC-3AINIT-20TYPE-29 "GEB.SPEC:INIT TYPE" - [f914]: #x-28GEB-2ESPEC-3ACOMP-20TYPE-29 "GEB.SPEC:COMP TYPE" - [fae9]: #x-28GEB-2ESPEC-3AINJECT-RIGHT-20TYPE-29 "GEB.SPEC:INJECT-RIGHT TYPE" - [fb12]: #x-28GEB-2ESPEC-3ACOPROD-20TYPE-29 "GEB.SPEC:COPROD TYPE" + [fa6c]: #x-28GEB-2EBITC-2ESPEC-3AZERO-20MGL-PAX-3ASYMBOL-MACRO-29 "GEB.BITC.SPEC:ZERO MGL-PAX:SYMBOL-MACRO" + [fb79]: #x-28GEB-2ESPEC-3A-3CSUBSTOBJ-3E-20CLASS-29 "GEB.SPEC: CLASS" + [fc10]: #x-28GEB-2EBITC-2ESPEC-3A-40BITC-CONSTRUCTORS-20MGL-PAX-3ASECTION-29 "Bits (Boolean Circuit) Constructors" + [fcda]: #x-28GEB-2ELAMBDA-2ESPEC-3ALTM-20GENERIC-FUNCTION-29 "GEB.LAMBDA.SPEC:LTM GENERIC-FUNCTION" [ff98]: #x-28GEB-GUI-2ECORE-3ANODE-20CLASS-29 "GEB-GUI.CORE:NODE CLASS" * * * diff --git a/docs/documentation.lisp b/docs/documentation.lisp index 841c65808..1c9e37c6e 100644 --- a/docs/documentation.lisp +++ b/docs/documentation.lisp @@ -11,6 +11,7 @@ (@model pax:section) (@idioms pax:section) (@geb pax:section) + (@geb-extensions pax:section) (@geb-gui-manual pax:section) (@bitc-manual pax:section) (@poly-manual pax:section) @@ -390,7 +391,7 @@ In this piece of code we can notice a few things: 4. We can write further methods extending the function to other subtypes. -Thus the [GEB:TO-POLY] function is written in such a way that it +Thus the [GEB.COMMON:TO-POLY] function is written in such a way that it supports a closed definition and open extensions, with [GEB.UTILS:SUBCLASS-RESPONSIBILITY] serving to be called if an extension a user wrote has no handling of this method. diff --git a/docs/package.lisp b/docs/package.lisp index c78e43f33..22a6f8189 100644 --- a/docs/package.lisp +++ b/docs/package.lisp @@ -10,4 +10,6 @@ (:import-from #:geb.entry #:@geb-entry) (:import-from #:geb.lambda #:@stlc) (:import-from #:geb-gui #:@geb-gui-manual) + (:import-from #:geb.extension.spec + #:@geb-extensions) (:export build-docs)) diff --git a/geb-idris/src/Executable/Test/Main.idr b/geb-idris/src/Executable/Test/Main.idr index b5e2bb5cf..bdae4be2d 100644 --- a/geb-idris/src/Executable/Test/Main.idr +++ b/geb-idris/src/Executable/Test/Main.idr @@ -6,7 +6,10 @@ import Library.Test.IdrisCategoriesTest import LanguageDef.Test.NatPrefixCatTest import LanguageDef.Test.ADTCatTest import LanguageDef.Test.ProgFinSetTest +import LanguageDef.Test.DiagramCatTest +import LanguageDef.Test.AdjunctionsTest import LanguageDef.Test.GebToposTest +import LanguageDef.Test.GenPolyFuncTest import LanguageDef.Test.PolyCatTest import LanguageDef.Test.PolyProfunctorTest import LanguageDef.Test.AtomTest @@ -45,4 +48,7 @@ main = do LanguageDef.Test.ADTCatTest.adtCatTest LanguageDef.Test.ProgFinSetTest.progFinSetTest LanguageDef.Test.SyntaxTest.languageDefSyntaxTest + LanguageDef.Test.DiagramCatTest.diagramCatTest + LanguageDef.Test.AdjunctionsTest.adjunctionsTest + LanguageDef.Test.GenPolyFuncTest.genPolyFuncTest LanguageDef.Test.GebToposTest.gebToposTest diff --git a/geb-idris/src/LanguageDef/ADTCat.idr b/geb-idris/src/LanguageDef/ADTCat.idr index 15f688135..60d1d5c32 100644 --- a/geb-idris/src/LanguageDef/ADTCat.idr +++ b/geb-idris/src/LanguageDef/ADTCat.idr @@ -2916,7 +2916,8 @@ MetaPolyFNat = metaPolyCata MetaPolyFNatAlg public export PolyHomObjAlg : MetaPolyPairAdjAlg PolyMu -- id -> r == r . (id + 1) (see formula 4.27 in _Polynomial Functors: A General --- Theory of Interaction_) +-- Theory of Interaction_; a more general form for any covariant representable +-- `id^A` is `id^A -> r == r . (id + A)`) PolyHomObjAlg PFI r = r $. (PolyI $+ Poly1) -- 0 -> x == 1 PolyHomObjAlg PF0 _ = Poly1 @@ -3276,12 +3277,10 @@ public export ($!) : ADTTerm ($!) = InADTT ADTUnit -prefix 10 $< public export ($<) : ADTTerm -> ADTTerm ($<) t = InADTT (ADTLeft t) -prefix 10 $> public export ($>) : ADTTerm -> ADTTerm ($>) t = InADTT (ADTRight t) diff --git a/geb-idris/src/LanguageDef/Adjunctions.idr b/geb-idris/src/LanguageDef/Adjunctions.idr new file mode 100644 index 000000000..44bc426b5 --- /dev/null +++ b/geb-idris/src/LanguageDef/Adjunctions.idr @@ -0,0 +1,258 @@ +module LanguageDef.Adjunctions + +import Library.IdrisUtils +import Library.IdrisCategories +import public LanguageDef.Atom +import public LanguageDef.ProgFinSet +import public LanguageDef.PolyCat +import public LanguageDef.Syntax +import public LanguageDef.DiagramCat + +%default total + +------------------------------------ +------------------------------------ +---- Left and right adjunctions ---- +------------------------------------ +------------------------------------ + +public export +AdjObjF : Type +AdjObjF = Diagram -> Type + +public export +DgmObjP : Type +DgmObjP = (Diagram, AdjObjF) + +public export +data ObjApplyObj : SliceObj DgmObjP where + OAppV : dgm.dVert -> ObjApplyObj (dgm, objf) + OAppC : objf dgm -> ObjApplyObj (dgm, objf) + +public export +data ObjApplyHom : (dop : DgmObjP) -> HomSlice (ObjApplyObj dop) where + OAppH : {x, y : dgm.dVert} -> + dgm.dEdge (x, y) -> ObjApplyHom (dgm, objf) (OAppV x, OAppV y) + +public export +data ObjApplyRel : (dop : DgmObjP) -> SigRelT (ObjApplyHom dop) where + OAppRv : {x, y : dgm.dVert} -> {f, g : dgm.dEdge (x, y)} -> + dgm.dRel ((x, y) ** (f, g)) -> + ObjApplyRel (dgm, objf) ((OAppV x, OAppV y) ** (OAppH f, OAppH g)) + +-- This extends only the object part of the diagram. +public export +objApply : DgmObjP -> Diagram +objApply dop = MkDiagram (ObjApplyObj dop) (ObjApplyHom dop) (ObjApplyRel dop) + +public export +LeftAdjUnitHomF : AdjObjF -> Type +LeftAdjUnitHomF objf = (dgm : Diagram) -> SliceObj (dgm.dVert, objf dgm) + +public export +LAUnitP : Type +LAUnitP = (dop : DgmObjP ** LeftAdjUnitHomF (snd dop)) + +-- The unit extends only the morphisms, not the objects. +public export +LAUApplyObj : SliceObj LAUnitP +LAUApplyObj dop = ObjApplyObj (fst dop) + +-- For a left adjoint, the unit provides the constructors. These we +-- treat as injective, like any typical datatype constructor -- hence +-- the unit introduces no equalities, only new morphisms. Furthermore, +-- because these are only constructors, they only introduce new morphisms +-- into the new objects, not out of them. +public export +data LAUApplyHom : (lup : LAUnitP) -> HomSlice (LAUApplyObj lup) where + LAUHv : + {0 dgm : Diagram} -> {objf : AdjObjF} -> {lau : LeftAdjUnitHomF objf} -> + {x, y : dgm.dVert} -> + dgm.dEdge (x, y) -> LAUApplyHom ((dgm, objf) ** lau) (OAppV x, OAppV y) + LAUHc : + {0 dgm : Diagram} -> {objf : AdjObjF} -> {lau : LeftAdjUnitHomF objf} -> + {x : dgm.dVert} -> {y : objf dgm} -> + lau dgm (x, y) -> LAUApplyHom ((dgm, objf) ** lau) (OAppV x, OAppC y) + +-- We treat the constructors (which, for a left adjoint, come from the unit) +-- treat as injective, like any typical datatype constructor -- hence +-- the unit introduces no equalities, only new morphisms. +public export +data LAUApplyRel : (lup : LAUnitP) -> SigRelT (LAUApplyHom lup) where + LAURv : + {0 dgm : Diagram} -> {objf : AdjObjF} -> {lau : LeftAdjUnitHomF objf} -> + {x, y : dgm.dVert} -> {f, g : dgm.dEdge (x, y)} -> + ObjApplyRel (dgm, objf) ((OAppV x, OAppV y) ** (OAppH f, OAppH g)) -> + LAUApplyRel + ((dgm, objf) ** lau) ((OAppV x, OAppV y) ** + (LAUHv {dgm} {lau} {x} {y} f, LAUHv {dgm} {lau} {x} {y} g)) + +public export +lauApply : LAUnitP -> Diagram +lauApply lup = MkDiagram (LAUApplyObj lup) (LAUApplyHom lup) (LAUApplyRel lup) + +public export +RightAdjCounitHomF : AdjObjF -> Type +RightAdjCounitHomF objf = (dgm : Diagram) -> SliceObj (objf dgm, dgm.dVert) + +public export +RACounitP : Type +RACounitP = (dop : DgmObjP ** RightAdjCounitHomF (snd dop)) + +-- The counit extends only the morphisms, not the objects. +public export +RACApplyObj : SliceObj RACounitP +RACApplyObj dop = ObjApplyObj (fst dop) + +-- For a right adjoint, the counit provides the constructors. These we +-- treat as injective, like any typical datatype constructor -- hence +-- the counit introduces no equalities, only new morphisms. Furthermore, +-- because these are only constructors, they only introduce new morphisms +-- into the new objects, not out of them. +public export +data RACApplyHom : (rcp : RACounitP) -> HomSlice (RACApplyObj rcp) where + RACHv : {0 dgm : Diagram} -> {objf : AdjObjF} -> + {rac : RightAdjCounitHomF objf} -> + {x, y : dgm.dVert} -> + dgm.dEdge (x, y) -> RACApplyHom ((dgm, objf) ** rac) (OAppV x, OAppV y) + RACHc : {0 dgm : Diagram} -> {objf : AdjObjF} -> + {rac : RightAdjCounitHomF objf} -> + {x : objf dgm} -> {y : dgm.dVert} -> + rac dgm (x, y) -> RACApplyHom ((dgm, objf) ** rac) (OAppC x, OAppV y) + +-- We treat the constructors (which, for a right adjoint, come from the counit) +-- treat as injective, like any typical datatype constructor -- hence +-- the counit introduces no equalities, only new morphisms. +public export +data RACApplyRel : (rcp : RACounitP) -> SigRelT (RACApplyHom rcp) where + RACRv : {0 dgm : Diagram} -> {objf : AdjObjF} -> + {rac : RightAdjCounitHomF objf} -> + {x, y : dgm.dVert} -> {f, g : dgm.dEdge (x, y)} -> + ObjApplyRel (dgm, objf) ((OAppV x, OAppV y) ** (OAppH f, OAppH g)) -> + RACApplyRel + ((dgm, objf) ** rac) ((OAppV x, OAppV y) ** + (RACHv {dgm} {rac} {x} {y} f, RACHv {dgm} {rac} {x} {y} g)) + +public export +racApply : RACounitP -> Diagram +racApply rcp = MkDiagram (RACApplyObj rcp) (RACApplyHom rcp) (RACApplyRel rcp) + +public export +LARightAdjunctHomF : {objf : AdjObjF} -> LeftAdjUnitHomF objf -> Type +LARightAdjunctHomF {objf} unit = + (dgm : Diagram) -> HomSlice (LAUApplyObj ((dgm, objf) ** unit)) + +public export +RALeftAdjunctHomF : {objf : AdjObjF} -> RightAdjCounitHomF objf -> Type +RALeftAdjunctHomF {objf} counit = + (dgm : Diagram) -> HomSlice (RACApplyObj ((dgm, objf) ** counit)) + +------------------ +------------------ +---- Examples ---- +------------------ +------------------ + +public export +data InitObjF : AdjObjF where + InitObj : InitObjF dgm + +public export +data InitUnitF : LeftAdjUnitHomF InitObjF where + +public export +data InitRightAdjunctHomF : LARightAdjunctHomF InitUnitF where + InitMorph : (a : dgm.dVert) -> + InitRightAdjunctHomF dgm (OAppC InitObj, OAppV a) + +public export +data TermObjF : AdjObjF where + TermObj : TermObjF dgm + +public export +data TermCounitF : RightAdjCounitHomF TermObjF where + +public export +data TermLeftAdjunctHomF : RALeftAdjunctHomF TermCounitF where + TermMorph : (a : dgm.dVert) -> + TermLeftAdjunctHomF dgm (OAppV a, OAppC TermObj) + +public export +data CoprodObjF : AdjObjF where + CopObj : dgm.dVert -> dgm.dVert -> CoprodObjF dgm + +public export +data CoprodUnitF : LeftAdjUnitHomF CoprodObjF where + CopInjL : (x, y : dgm.dVert) -> CoprodUnitF dgm (x, CopObj x y) + CopInjR : (x, y : dgm.dVert) -> CoprodUnitF dgm (y, CopObj x y) + +public export +data CoprodRightAdjunctHomF : LARightAdjunctHomF CoprodUnitF where + CopCase : + {a, b : dgm.dVert} -> {c : ObjApplyObj (dgm, CoprodObjF)} -> + LAUApplyHom ((dgm, CoprodObjF) ** CoprodUnitF) (OAppV a, c) -> + LAUApplyHom ((dgm, CoprodObjF) ** CoprodUnitF) (OAppV b, c) -> + CoprodRightAdjunctHomF dgm (OAppC (CopObj a b), c) + +public export +data ProdObjF : AdjObjF where + PrObj : dgm.dVert -> dgm.dVert -> ProdObjF dgm + +public export +data ProdCounitF : RightAdjCounitHomF ProdObjF where + PrProjL : (x, y : dgm.dVert) -> ProdCounitF dgm (PrObj x y, x) + PrProjR : (x, y : dgm.dVert) -> ProdCounitF dgm (PrObj x y, y) + +public export +data ProdLeftAdjunctHomF : RALeftAdjunctHomF ProdCounitF where + ProdBi : + {a : ObjApplyObj (dgm, ProdObjF)} -> {b, c : dgm.dVert} -> + RACApplyHom ((dgm, ProdObjF) ** ProdCounitF) (a, OAppV b) -> + RACApplyHom ((dgm, ProdObjF) ** ProdCounitF) (a, OAppV c) -> + ProdLeftAdjunctHomF dgm (a, OAppC (PrObj b c)) + +public export +data CoeqObjF : AdjObjF where + CoeqObj : {x, y : dgm.dVert} -> + dgm.dEdge (x, y) -> dgm.dEdge (x, y) -> CoeqObjF dgm + +public export +data CoeqUnitF : LeftAdjUnitHomF CoeqObjF where + CoeqIntroInj : {x, y : dgm.dVert} -> + (f, g : dgm.dEdge (x, y)) -> CoeqUnitF dgm (y, CoeqObj {x} {y} f g) + +public export +data CoeqRightAdjunctHomF : LARightAdjunctHomF CoeqUnitF where + CoeqElim : {dgm : Diagram} -> + {x, y : dgm.dVert} -> {z : ObjApplyObj (dgm, CoeqObjF)} -> + {f, g : dgm.dEdge (x, y)} -> + (h : LAUApplyHom ((dgm, CoeqObjF) ** CoeqUnitF) (OAppV y, z)) -> + -- Eliminating a coequalizer requires proof content: h . f = h . g + CatFreeEq (LAUApplyRel ((dgm, CoeqObjF) ** CoeqUnitF)) + ((OAppV {dgm} x, z) ** + (InSlFc $ CHComp (InSlFv h) (InSlFv $ LAUHv f), + InSlFc $ CHComp (InSlFv h) (InSlFv $ LAUHv g))) -> + CoeqRightAdjunctHomF dgm (OAppC (CoeqObj {x} {y} f g), z) + +public export +data EqObjF : AdjObjF where + EqObj : {x, y : dgm.dVert} -> + dgm.dEdge (x, y) -> dgm.dEdge (x, y) -> EqObjF dgm + +public export +data EqCounitF : RightAdjCounitHomF EqObjF where + EqElimInj : {x, y : dgm.dVert} -> + (f, g : dgm.dEdge (x, y)) -> EqCounitF dgm (EqObj {x} {y} f g, x) + +public export +data EqLeftAdjunctHomF : RALeftAdjunctHomF EqCounitF where + EqIntro : + {a : ObjApplyObj (dgm, EqObjF)} -> {x, y : dgm.dVert} -> + {f, g : dgm.dEdge (x, y)} -> + (h : RACApplyHom ((dgm, EqObjF) ** EqCounitF) (a, OAppV x)) -> + -- Introducing an equalizer requires proof content: f . h = g . h + CatFreeEq (RACApplyRel ((dgm, EqObjF) ** EqCounitF)) + ((a, OAppV {dgm} y) ** + (InSlFc $ CHComp (InSlFv $ RACHv f) (InSlFv h), + InSlFc $ CHComp (InSlFv $ RACHv g) (InSlFv h))) -> + EqLeftAdjunctHomF dgm (a, OAppC (EqObj {x} {y} f g)) diff --git a/geb-idris/src/LanguageDef/Atom.idr b/geb-idris/src/LanguageDef/Atom.idr index 2cb9a1459..8b31b9a66 100644 --- a/geb-idris/src/LanguageDef/Atom.idr +++ b/geb-idris/src/LanguageDef/Atom.idr @@ -44,12 +44,28 @@ data GebAtom : Type where DIR_XCHD : GebAtom DIR_XCTL : GebAtom + -- Finite unrefined types + FBT_ATOM : GebAtom + FBT_BNAT : GebAtom + FBT_INITIAL : GebAtom + FBT_COPRODUCT : GebAtom + FBT_COPRODUCT_L : GebAtom + FBT_TERMINAL : GebAtom + FBT_PRODUCT : GebAtom + FBT_PRODUCT_L : GebAtom + + -- Terms of finite product/coproduct types + TERM_U : GebAtom + TERM_L : GebAtom + TERM_R : GebAtom + TERM_P : GebAtom + -- The rest of this file implements enumerated-type interfaces for `GebAtom`, -- since Idris-2 doesn't have built-in enums. public export GASize : Nat -GASize = 20 +GASize = 32 public export GAFin : Type @@ -93,6 +109,49 @@ GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ))))))))))))))))))) = DIR_XCTL +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS FZ)))))))))))))))))))) = + FBT_ATOM +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS FZ))))))))))))))))))))) = + FBT_BNAT +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))))))))))))))))) = + FBT_INITIAL +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ))))))))))))))))))))))) = + FBT_COPRODUCT +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))))))))))))))))))) = + FBT_COPRODUCT_L +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + FZ))))))))))))))))))))))))) = + FBT_TERMINAL +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS FZ)))))))))))))))))))))))))) = + FBT_PRODUCT +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS FZ))))))))))))))))))))))))))) = + FBT_PRODUCT_L +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS FZ)))))))))))))))))))))))))))) = + TERM_U +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS FZ))))))))))))))))))))))))))))) = + TERM_L +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS FZ)))))))))))))))))))))))))))))) = + TERM_R +GADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS + (FS (FS (FS (FS (FS (FS FZ))))))))))))))))))))))))))))))) = + TERM_P public export GAEncoder : NatEncoder GADecoder @@ -116,6 +175,18 @@ GAEncoder DIR_NCHD = (16 ** Refl ** Refl) GAEncoder DIR_NCTL = (17 ** Refl ** Refl) GAEncoder DIR_XCHD = (18 ** Refl ** Refl) GAEncoder DIR_XCTL = (19 ** Refl ** Refl) +GAEncoder FBT_ATOM = (20 ** Refl ** Refl) +GAEncoder FBT_BNAT = (21 ** Refl ** Refl) +GAEncoder FBT_INITIAL = (22 ** Refl ** Refl) +GAEncoder FBT_COPRODUCT = (23 ** Refl ** Refl) +GAEncoder FBT_COPRODUCT_L = (24 ** Refl ** Refl) +GAEncoder FBT_TERMINAL = (25 ** Refl ** Refl) +GAEncoder FBT_PRODUCT = (26 ** Refl ** Refl) +GAEncoder FBT_PRODUCT_L = (27 ** Refl ** Refl) +GAEncoder TERM_U = (28 ** Refl ** Refl) +GAEncoder TERM_L = (29 ** Refl ** Refl) +GAEncoder TERM_R = (30 ** Refl ** Refl) +GAEncoder TERM_P = (31 ** Refl ** Refl) public export GebAtomEncoding : FinDecEncoding GebAtom GASize @@ -143,6 +214,18 @@ gaToString DIR_NCHD = "DIR_NCHD" gaToString DIR_NCTL = "DIR_NCTL" gaToString DIR_XCHD = "DIR_XCHD" gaToString DIR_XCTL = "DIR_XCTL" +gaToString FBT_ATOM = "FBT_ATOM" +gaToString FBT_BNAT = "FBT_BNAT" +gaToString FBT_INITIAL = "FBT_INITIAL" +gaToString FBT_COPRODUCT = "FBT_COPRODUCT" +gaToString FBT_COPRODUCT_L = "FBT_COPRODUCT_L" +gaToString FBT_TERMINAL = "FBT_TERMINAL" +gaToString FBT_PRODUCT = "FBT_PRODUCT" +gaToString FBT_PRODUCT_L = "FBT_PRODUCT_L" +gaToString TERM_U = "TERM_U" +gaToString TERM_L = "TERM_L" +gaToString TERM_R = "TERM_R" +gaToString TERM_P = "TERM_P" public export Show GebAtom where diff --git a/geb-idris/src/LanguageDef/DiagramCat.idr b/geb-idris/src/LanguageDef/DiagramCat.idr new file mode 100644 index 000000000..fb8d41de4 --- /dev/null +++ b/geb-idris/src/LanguageDef/DiagramCat.idr @@ -0,0 +1,483 @@ +module LanguageDef.DiagramCat + +import Library.IdrisUtils +import Library.IdrisCategories +import public LanguageDef.Atom +import public LanguageDef.ProgFinSet +import public LanguageDef.PolyCat +import public LanguageDef.Syntax + +%default total + +---------------------------------------- +---------------------------------------- +---- Category-signature definitions ---- +---------------------------------------- +---------------------------------------- + +public export +SignatureT : Type -> Type +SignatureT = ProductMonad + +public export +HomSlice : Type -> Type +HomSlice = SliceObj . SignatureT + +public export +SigRelObj : {obj : Type} -> SliceObj (HomSlice obj) +SigRelObj {obj} hom = DepRelObj {a=(SignatureT obj)} (hom, hom) + +public export +SigRelT : {obj : Type} -> SliceObj (HomSlice obj) +SigRelT {obj} hom = DepRelOn {a=(SignatureT obj)} (hom, hom) + +public export +HomEndofunctor : Type -> Type +HomEndofunctor = SliceEndofunctor . SignatureT + +public export +InternalCopresheaf : Type -> Type +InternalCopresheaf = SliceObj + +public export +InternalCopresheafNT : {obj : Type} -> SliceObj obj -> SliceObj obj -> Type +InternalCopresheafNT {obj} = SliceMorphism {a=obj} + +public export +CopresheafNTExtEq : {obj : Type} -> {f, g : InternalCopresheaf obj} -> + (alpha, beta : InternalCopresheafNT f g) -> Type +CopresheafNTExtEq {obj} {f} {g} = SliceExtEq {a=obj} {s=f} {s'=g} + +public export +InternalCovarHom : HomSlice obj -> obj -> SliceObj obj +InternalCovarHom hom = hom .* MkPair + +public export +InternalContravarHom : HomSlice obj -> obj -> SliceObj obj +InternalContravarHom = flip . InternalCovarHom + +public export +HomUncurry : (obj -> obj -> Type) -> HomSlice obj +HomUncurry hom (x, y) = hom x y + +public export +InternalNTFromCovarHom : {obj : Type} -> + (hom : HomSlice obj) -> obj -> SliceObj obj -> Type +InternalNTFromCovarHom {obj} hom = + SliceMorphism {a=obj} . InternalCovarHom hom + +public export +InternalNTFromContravarHom : {obj : Type} -> + (hom : HomSlice obj) -> obj -> SliceObj obj -> Type +InternalNTFromContravarHom {obj} hom = + SliceMorphism {a=obj} . InternalContravarHom hom + +--------------------------------------------------------------- +--------------------------------------------------------------- +---- Standard (Mac Lane / Eilenberg) internal categories ---- +--------------------------------------------------------------- +--------------------------------------------------------------- + +public export +record SCat where + constructor SC + scObj : Type + scHom : HomSlice scObj + scId : (a : scObj) -> scHom (a, a) + scComp : {a, b, c : scObj} -> scHom (b, c) -> scHom (a, b) -> scHom (a, c) + scEq : (sig : SignatureT scObj) -> EqRel (scHom sig) + 0 scIdL : {0 a, b : scObj} -> (f : scHom (a, b)) -> + (scEq (a, b)).eqRel f (scComp {a} {b} {c=b} (scId b) f) + 0 scIdR : {0 a, b : scObj} -> (f : scHom (a, b)) -> + (scEq (a, b)).eqRel f (scComp {a} {b=a} {c=b} f (scId a)) + 0 scIdAssoc : {0 a, b, c, d : scObj} -> + (f : scHom (a, b)) -> (g : scHom (b, c)) -> (h : scHom (c, d)) -> + (scEq (a, d)).eqRel + (scComp {a} {b=c} {c=d} h (scComp {a} {b} {c} g f)) + (scComp {a} {b} {c=d} (scComp {a=b} {b=c} {c=d} h g) f) + +---------------------------------------- +---- Standard-category Yoneda lemma ---- +---------------------------------------- + +public export +SCCovarHomYonedaR : + (sc : SCat) -> (a : sc.scObj) -> (f : SliceObj sc.scObj) -> + InternalNTFromCovarHom {obj=sc.scObj} sc.scHom a f -> f a +SCCovarHomYonedaR sc a f alpha = alpha a $ sc.scId a + +public export +SCCovarHomYonedaL : (sc : SCat) -> (a : sc.scObj) -> (f : SliceObj sc.scObj) -> + (fmap : (a, b : sc.scObj) -> sc.scHom (a, b) -> f a -> f b) -> + f a -> InternalNTFromCovarHom {obj=sc.scObj} sc.scHom a f +SCCovarHomYonedaL sc a f fmap fa b mab = fmap a b mab fa + +public export +SCContravarHomYonedaR : + (sc : SCat) -> (a : sc.scObj) -> (f : SliceObj sc.scObj) -> + InternalNTFromContravarHom {obj=sc.scObj} sc.scHom a f -> f a +SCContravarHomYonedaR sc a f alpha = alpha a $ sc.scId a + +public export +SCContravarHomYonedaL : + (sc : SCat) -> (a : sc.scObj) -> (f : SliceObj sc.scObj) -> + -- f is contravariant + (fmap : (a, b : sc.scObj) -> sc.scHom (a, b) -> f b -> f a) -> + f a -> InternalNTFromContravarHom {obj=sc.scObj} sc.scHom a f +SCContravarHomYonedaL sc a f fmap fa b mba = fmap b a mba fa + +------------------------- +------------------------- +---- Free categories ---- +------------------------- +------------------------- + +-- The (free-forgetful) adjunction which can be used to define a category +-- has the following data: +-- +-- - Left category C: two-category of categories +-- - Right category D: category of diagrams +-- - Left functor L: free functor which adds identities (loop edges) for +-- each vertex and paths to represent compositions, and equalities for +-- left identity, right identity, and associativity +-- - Right functor R: forgetful functor which drops identity, composition, +-- and equalities, leaving just vertices and edges +-- - R . L (D -> D): Functor which closes a diagram with loops labeled +-- as identities and paths labeled as compositions +-- - L . R (C -> C): Identity functor +-- - Unit (id -> R . L): injection of diagram into its closure +-- - Counit (L . R -> id): identity natural transformation +-- - Adjuncts: (Hom(L A, B) == Hom(A, R B), for A : D and B : C): +-- functors from a free category generated from a diagram A to an arbitrary +-- category B are in bijection with graph homomorphisms from A to the +-- diagram underlying B (i.e. the diagram whose vertices are objects of B +-- and whose edges are morphisms of B) +-- - Left triangle identity: (counit . L) . (L . unit) = id(L): +-- expanded, for all A : D, counit(L(A)) . L(unit(A)) = id(L(A)) +-- (which goes from L(A) to L(A) in C via L(R(L(A)))): +-- id(L(A)) . L(inj(A)) = id(L(A)) +-- -- this reflects preservation of identities by functors +-- - Right triangle identity: (R . counit) . (unit . R) = id(R): +-- expanded, for all B : C, R(counit(B)) . unit(R(B)) = id(R(B)) +-- (which goes from R(B) to R(B) in D via R(L(R(B)))): +-- id(forget(B)) . inj(forget(B)) = id(forget(B)) +-- -- this reflects the definition of the injection + +public export +data CatHomF : {0 obj : Type} -> HomEndofunctor obj where + CHId : + {0 obj : Type} -> {0 hom : HomSlice obj} -> + (x : obj) -> CatHomF {obj} hom (x, x) + CHComp : + {0 obj : Type} -> {0 hom : HomSlice obj} -> {x, y, z : obj} -> + hom (y, z) -> hom (x, y) -> CatHomF {obj} hom (x, z) + +public export +HomTranslateF : (obj : Type) -> HomSlice obj -> HomEndofunctor obj +HomTranslateF obj = SliceTranslateF {a=(SignatureT obj)} (CatHomF {obj}) + +public export +CatEitherF : {obj : Type} -> HomEndofunctor obj +CatEitherF {obj} = SliceTrEitherF {a=(SignatureT obj)} (CatHomF {obj}) + +public export +CEid : {obj : Type} -> {0 hom : HomSlice obj} -> + (x : obj) -> CatEitherF {obj} hom (x, x) +CEid x = InSlC $ CHId x + +public export +CEcomp : {obj : Type} -> {0 hom : HomSlice obj} -> + {x, y, z: obj} -> hom (y, z) -> hom (x, y) -> CatEitherF {obj} hom (x, z) +CEcomp f g = InSlC $ CHComp f g + +public export +FreeHomM : (obj : Type) -> HomEndofunctor obj +FreeHomM obj = SliceFreeM {a=(SignatureT obj)} (CatHomF {obj}) + +public export +chId : {obj : Type} -> + (hom : HomSlice obj) -> (a : obj) -> FreeHomM obj hom (a, a) +chId {obj} hom a = InSlFc $ CHId a + +public export +chComp : {obj : Type} -> {a, b, c : obj} -> {hom : HomSlice obj} -> + FreeHomM obj hom (b, c) -> FreeHomM obj hom (a, b) -> FreeHomM obj hom (a, c) +chComp {obj} {a} {b} {c} {hom} g f = InSlFc $ CHComp g f + +public export +HomSliceCata : Type -> Type +HomSliceCata obj = SliceFreeCata {a=(SignatureT obj)} (CatHomF {obj}) + +public export +homSliceCata : {obj : Type} -> HomSliceCata obj +homSliceCata {obj} sv sa subst alg (a, b) (InSlF (a, b) (InSlV v)) = + subst (a, b) v +homSliceCata {obj} sv sa subst alg (a, b) (InSlF (a, b) (InSlC m)) = + alg (a, b) $ case m of + CHId c => CHId c + CHComp {x} {y} {z} g f => + CHComp {x} {y} {z} + (homSliceCata {obj} sv sa subst alg (y, z) g) + (homSliceCata {obj} sv sa subst alg (x, y) f) + +public export +chFreeFMap : {obj : Type} -> {hom : HomSlice obj} -> {f : SliceObj obj} -> + ((a, b : obj) -> hom (a, b) -> f a -> f b) -> + ((a, b : obj) -> FreeHomM obj hom (a, b) -> f a -> f b) +chFreeFMap {obj} {hom} {f} fmap a b = + homSliceCata hom (\(x, y) => f x -> f y) + (\(x, y) => fmap x y) + (\(x, z), m => case m of CHId z => id ; CHComp g f => g . f) + (a, b) + +public export +chFreeFContramap : {obj : Type} -> {hom : HomSlice obj} -> {f : SliceObj obj} -> + ((a, b : obj) -> hom (a, b) -> f b -> f a) -> + ((a, b : obj) -> FreeHomM obj hom (a, b) -> f b -> f a) +chFreeFContramap {obj} {hom} {f} fmap a b = + homSliceCata hom (\(x, y) => f y -> f x) + (\(x, y) => fmap x y) + (\(x, z), m => case m of CHId z => id ; CHComp g f => f . g) + (a, b) + +public export +FreeHomRel : {obj : Type} -> SliceObj (HomSlice obj) +FreeHomRel {obj} hom = + DepRelOn {a=(SignatureT obj)} (FreeHomM obj hom, FreeHomM obj hom) + +public export +FreeHomEqF : {obj : Type} -> (hom : HomSlice obj) -> + FreeHomRel {obj} hom -> FreeHomRel {obj} hom +FreeHomEqF {obj} hom = DepFreeEqF {a=(SignatureT obj)} {sl=(FreeHomM obj hom)} + +public export +CatRelObj : {obj : Type} -> SliceObj (HomSlice obj) +CatRelObj {obj} hom = SigRelObj {obj} (FreeHomM obj hom) + +public export +CatRelT : {obj : Type} -> SliceObj (HomSlice obj) +CatRelT {obj} hom = SigRelT {obj} (FreeHomM obj hom) + +public export +data SigToCatRel : {obj : Type} -> {hom : HomSlice obj} -> + SigRelT {obj} hom -> CatRelT {obj} hom where + StoCR : {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 rv : SigRelT hom} -> + {0 a, b : obj} -> {0 f, g : hom (a, b)} -> + rv ((a, b) ** (f, g)) -> + SigToCatRel {obj} {hom} rv ((a, b) ** (InSlFv f, InSlFv g)) + +public export +data CatEqAx : {obj : Type} -> {hom : HomSlice obj} -> CatRelT hom where + CEidL : + {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 a, b : obj} -> (0 f : FreeHomM obj hom (a, b)) -> + CatEqAx {obj} {hom} ((a, b) ** (f, chComp (chId hom b) f)) + CEidR : + {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 a, b : obj} -> (0 f : FreeHomM obj hom (a, b)) -> + CatEqAx {obj} {hom} ((a, b) ** (f, chComp f (chId hom a))) + CEassoc : + {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 a, b, c, d : obj} -> + (0 f : FreeHomM obj hom (a, b)) -> + (0 g : FreeHomM obj hom (b, c)) -> + (0 h : FreeHomM obj hom (c, d)) -> + CatEqAx {obj} {hom} + ((a, d) ** (chComp h (chComp g f), chComp (chComp h g) f)) + +public export +data CatFreeEqF : {obj : Type} -> {hom : HomSlice obj} -> + CatRelT hom -> CatRelT hom where + CEax : {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 ra : CatRelT hom} -> + {0 a, b : obj} -> {0 f, g : FreeHomM obj hom (a, b)} -> + CatEqAx {obj} {hom} ((a, b) ** (f, g)) -> + CatFreeEqF {obj} {hom} ra ((a, b) ** (f, g)) + CEeq : {0 obj : Type} -> {0 hom : HomSlice obj} -> + {0 ra : CatRelT hom} -> + {0 a, b : obj} -> {0 f, g : FreeHomM obj hom (a, b)} -> + FreeHomEqF {obj} hom ra ((a, b) ** (f, g)) -> + CatFreeEqF {obj} {hom} ra ((a, b) ** (f, g)) + +public export +CatFreeEq : {obj : Type} -> {hom : HomSlice obj} -> (rel : SigRelT hom) -> + CatRelT hom +CatFreeEq {obj} {hom} rel = + SliceFreeM + {a=(CatRelObj {obj} hom)} + (CatFreeEqF {obj} {hom}) + (SigToCatRel rel) + +public export +record Diagram where + constructor MkDiagram + dVert : Type + dEdge : HomSlice dVert + -- `dRel` is a relation which, when we freely generate a category from + -- the diagram, will freely generate an equivalence relation, but `dRel` + -- itself does not promise to be an equivalence relation. + dRel : SigRelT dEdge + +public export +diagToCatForget : SCat -> Diagram +diagToCatForget sc = + MkDiagram sc.scObj sc.scHom (\(sig ** (f, g)) => eqRel (sc.scEq sig) f g) + +public export +DiagFreeObj : Diagram -> Type +DiagFreeObj diag = diag.dVert + +public export +DiagFreeSig : Diagram -> Type +DiagFreeSig = SignatureT . DiagFreeObj + +public export +DiagFreeHom : (diag : Diagram) -> HomSlice (DiagFreeObj diag) +DiagFreeHom diag = FreeHomM diag.dVert diag.dEdge + +public export +diagFreeId : + (diag : Diagram) -> (a : DiagFreeObj diag) -> DiagFreeHom diag (a, a) +diagFreeId diag a = chId diag.dEdge a + +public export +diagFreeComp : {diag : Diagram} -> {a, b, c : DiagFreeObj diag} -> + DiagFreeHom diag (b, c) -> DiagFreeHom diag (a, b) -> DiagFreeHom diag (a, c) +diagFreeComp {diag} g f = chComp {hom=diag.dEdge} g f + +public export +DiagFreeSigRel : (diag : Diagram) -> SigRelT (DiagFreeHom diag) +DiagFreeSigRel diag = CatFreeEq {obj=diag.dVert} {hom=diag.dEdge} diag.dRel + +public export +DiagFreeRel : (diag : Diagram) -> (sig : DiagFreeSig diag) -> + RelationOn (DiagFreeHom diag sig) +DiagFreeRel diag sig f g = DiagFreeSigRel diag (sig ** (f, g)) + +public export +DiagFreeRelIsRefl : (diag : Diagram) -> (a, b : DiagFreeObj diag) -> + IsReflexive (DiagFreeRel diag (a, b)) +DiagFreeRelIsRefl diag a b f = + InSlF ((a, b) ** (f, f)) $ InSlC $ CEeq $ DFErefl f + +public export +DiagFreeRelIsSym : (diag : Diagram) -> (a, b : DiagFreeObj diag) -> + IsSymmetric (DiagFreeRel diag (a, b)) +DiagFreeRelIsSym diag a b {x=f} {y=g} eq = + InSlF ((a, b) ** (g, f)) $ InSlC $ CEeq $ DFEsym eq + +public export +DiagFreeRelIsTrans : (diag : Diagram) -> (a, b : DiagFreeObj diag) -> + IsTransitive (DiagFreeRel diag (a, b)) +DiagFreeRelIsTrans diag a b {x=f} {y=g} {z=h} eqfg eqgh = + InSlF ((a, b) ** (f, h)) $ InSlC $ CEeq $ DFEtrans eqgh eqfg + +public export +DiagFreeRelIsEquiv : (diag : Diagram) -> (a, b : DiagFreeObj diag) -> + IsEquivalence (DiagFreeRel diag (a, b)) +DiagFreeRelIsEquiv diag a b = + MkEquivalence + (DiagFreeRelIsRefl diag a b) + (DiagFreeRelIsSym diag a b) + (DiagFreeRelIsTrans diag a b) + +public export +DiagFreeEqRel : (diag : Diagram) -> (sig : DiagFreeSig diag) -> + EqRel (DiagFreeHom diag sig) +DiagFreeEqRel diag (a, b) = + MkEq (DiagFreeRel diag (a, b)) (DiagFreeRelIsEquiv diag a b) + +public export +DiagFreeIdL : (diag : Diagram) -> {a, b : DiagFreeObj diag} -> + (f : DiagFreeHom diag (a, b)) -> + DiagFreeRel diag (a, b) f (diagFreeComp {diag} (diagFreeId diag b) f) +DiagFreeIdL diag {a} {b} f = + InSlF ((a, b) ** (f, diagFreeComp (diagFreeId diag b) f)) $ + InSlC $ CEax $ CEidL f + +public export +DiagFreeIdR : (diag : Diagram) -> {a, b : DiagFreeObj diag} -> + (f : DiagFreeHom diag (a, b)) -> + DiagFreeRel diag (a, b) f (diagFreeComp {diag} f (diagFreeId diag a)) +DiagFreeIdR diag {a} {b} f = + InSlF ((a, b) ** (f, diagFreeComp f (diagFreeId diag a))) $ + InSlC $ CEax $ CEidR f + +public export +DiagFreeAssoc : (diag : Diagram) -> {a, b, c, d : DiagFreeObj diag} -> + (f : DiagFreeHom diag (a, b)) -> + (g : DiagFreeHom diag (b, c)) -> + (h : DiagFreeHom diag (c, d)) -> + DiagFreeRel diag (a, d) + (diagFreeComp {diag} h (diagFreeComp {diag} g f)) + (diagFreeComp {diag} (diagFreeComp {diag} h g) f) +DiagFreeAssoc diag {a} {b} {c} {d} f g h = + InSlF + ((a, d) ** + (diagFreeComp {diag} h (diagFreeComp {diag} g f), + diagFreeComp {diag} (diagFreeComp {diag} h g) f)) $ + InSlC $ CEax $ CEassoc f g h + +public export +DiagToFreeCat : Diagram -> SCat +DiagToFreeCat diag = + SC + (DiagFreeObj diag) + (DiagFreeHom diag) + (diagFreeId diag) + (diagFreeComp {diag}) + (DiagFreeEqRel diag) + (DiagFreeIdL diag) + (DiagFreeIdR diag) + (DiagFreeAssoc diag) + +----------------------------------------- +----------------------------------------- +---- Polynomial functors on diagrams ---- +----------------------------------------- +----------------------------------------- + +public export +sigMap : (obj -> obj') -> SignatureT obj -> SignatureT obj' +sigMap m (a, b) = (m a, m b) + +public export +HomMap : {obj, obj' : Type} -> + (m : obj -> obj') -> HomSlice obj -> HomSlice obj' -> Type +HomMap {obj} m sl sl' = SliceMorphism {a=(SignatureT obj)} sl (sl' . sigMap m) + +public export +sigObjMap : {obj, obj' : Type} -> + {m : obj -> obj'} -> {sl : HomSlice obj} -> {sl' : HomSlice obj'} -> + HomMap {obj} {obj'} m sl sl' -> + SigRelObj sl -> SigRelObj sl' +sigObjMap {obj} {obj'} {m} {sl} {sl'} hm ((a, b) ** (f, g)) = + ((m a, m b) ** (hm (a, b) f, hm (a, b) g)) + +public export +HomRelMap : {obj, obj' : Type} -> + {m : obj -> obj'} -> {sl : HomSlice obj} -> {sl' : HomSlice obj'} -> + HomMap {obj} {obj'} m sl sl' -> + SigRelT sl -> SigRelT sl' -> + Type +HomRelMap {obj} {obj'} {m} {sl} {sl'} hm rel rel' = + SliceMorphism {a=(SigRelObj sl)} rel (rel' . sigObjMap hm) + +public export +record DiagFunctor (dom, cod : Diagram) where + constructor MkDiagF + dfVmap : dom.dVert -> cod.dVert + dfEmap : HomMap {obj=dom.dVert} dfVmap dom.dEdge cod.dEdge + 0 dfRmap : HomRelMap {m=dfVmap} dfEmap dom.dRel cod.dRel + +public export +record PolyDOF where + constructor PDOF + pdfPos : Type + pdfDir : pdfPos -> Diagram + +public export +pdofInterp : PolyDOF -> Diagram -> Type +pdofInterp pdof diag = + (i : pdof.pdfPos ** DiagFunctor (pdof.pdfDir i) diag) diff --git a/geb-idris/src/LanguageDef/GebTopos.idr b/geb-idris/src/LanguageDef/GebTopos.idr index 654a5e2ef..9b31a05af 100644 --- a/geb-idris/src/LanguageDef/GebTopos.idr +++ b/geb-idris/src/LanguageDef/GebTopos.idr @@ -6,9 +6,2432 @@ import public LanguageDef.Atom import public LanguageDef.ProgFinSet import public LanguageDef.PolyCat import public LanguageDef.Syntax +import public LanguageDef.DiagramCat +import public LanguageDef.Adjunctions %default total +-------------------------------- +-------------------------------- +---- Yoneda lemma utilities ---- +-------------------------------- +-------------------------------- + +------------------------------------------ +---- Internal natural transformations ---- +------------------------------------------ + +public export +CovarToCovarHomRep : {obj : Type} -> HomEndofunctor obj +CovarToCovarHomRep {obj} hom (a, b) = + InternalNTFromCovarHom {obj} hom b (InternalCovarHom hom a) + +public export +CovarToContravarHomRep : {obj : Type} -> HomEndofunctor obj +CovarToContravarHomRep {obj} hom (a, b) = + InternalNTFromCovarHom {obj} hom a (InternalContravarHom hom b) + +public export +ContravarToContravarHomRep : {obj : Type} -> HomEndofunctor obj +ContravarToContravarHomRep {obj} hom (a, b) = + InternalNTFromContravarHom {obj} hom a (InternalContravarHom hom b) + +public export +ContravarToCovarHomRep : {obj : Type} -> HomEndofunctor obj +ContravarToCovarHomRep {obj} hom (a, b) = + InternalNTFromContravarHom {obj} hom b (InternalCovarHom hom a) + +public export +data HomRep : {0 obj : Type} -> HomEndofunctor obj where + HRCovarToCovar : + CovarToCovarHomRep hom (a, b) -> HomRep hom (a, b) + HRCovarToContravar : + CovarToContravarHomRep hom (a, b) -> HomRep hom (a, b) + HRContravarToContravar : + ContravarToContravarHomRep hom (a, b) -> HomRep hom (a, b) + HRContravarToCovar : + ContravarToCovarHomRep hom (a, b) -> HomRep hom (a, b) + +public export +CovarToCovarHomRepExtEq : + {obj : Type} -> {hom : HomSlice obj} -> {a, b : obj} -> + (alpha, beta : CovarToCovarHomRep hom (a, b)) -> Type +CovarToCovarHomRepExtEq {obj} {hom} {a} {b} = + CopresheafNTExtEq {obj} + {f=(InternalCovarHom hom b)} {g=(InternalCovarHom hom a)} + +public export +CovarToContravarHomRepExtEq : + {obj : Type} -> {hom : HomSlice obj} -> {a, b : obj} -> + (alpha, beta : CovarToContravarHomRep hom (a, b)) -> Type +CovarToContravarHomRepExtEq {obj} {hom} {a} {b} = + CopresheafNTExtEq {obj} + {f=(InternalCovarHom hom a)} {g=(InternalContravarHom hom b)} + +public export +ContravarToContravarHomRepExtEq : + {obj : Type} -> {hom : HomSlice obj} -> {a, b : obj} -> + (alpha, beta : ContravarToContravarHomRep hom (a, b)) -> Type +ContravarToContravarHomRepExtEq {obj} {hom} {a} {b} = + CopresheafNTExtEq {obj} + {f=(InternalContravarHom hom a)} {g=(InternalContravarHom hom b)} + +public export +ContravarToCovarHomRepExtEq : + {obj : Type} -> {hom : HomSlice obj} -> {a, b : obj} -> + (alpha, beta : ContravarToCovarHomRep hom (a, b)) -> Type +ContravarToCovarHomRepExtEq {obj} {hom} {a} {b} = + CopresheafNTExtEq {obj} + {f=(InternalContravarHom hom b)} {g=(InternalCovarHom hom a)} + +public export +CovarToCovarHomSetRep : (obj : Type) -> HomEndofunctor obj +CovarToCovarHomSetRep obj hom (a, b) = + hom (a, b) -> CovarToCovarHomRep hom (a, b) + +public export +CovarToCovarCatRep : {obj : Type} -> HomSlice obj -> Type +CovarToCovarCatRep {obj} hom = + (a, b : obj) -> CovarToCovarHomSetRep obj hom (a, b) + +public export +CovarToContravarHomSetRep : (obj : Type) -> HomEndofunctor obj +CovarToContravarHomSetRep obj hom (a, b) = + hom (a, b) -> CovarToContravarHomRep hom (a, b) + +public export +ContravarToContravarHomSetRep : (obj : Type) -> HomEndofunctor obj +ContravarToContravarHomSetRep obj hom (a, b) = + hom (a, b) -> ContravarToContravarHomRep hom (a, b) + +public export +ContravarToContravarCatRep : {obj : Type} -> HomSlice obj -> Type +ContravarToContravarCatRep {obj} hom = + (a, b : obj) -> ContravarToContravarHomSetRep obj hom (a, b) + +public export +ContravarToCovarHomSetRep : (obj : Type) -> HomEndofunctor obj +ContravarToCovarHomSetRep obj hom (a, b) = + hom (a, b) -> ContravarToCovarHomRep hom (a, b) + +public export +data HomSetRep : (obj : Type) -> HomEndofunctor obj where + HSRCovarToCovar : + CovarToCovarHomSetRep obj hom (a, b) -> HomSetRep obj hom (a, b) + HSRCovarToContravar : + CovarToContravarHomSetRep obj hom (a, b) -> HomSetRep obj hom (a, b) + HSRContravarToContravar : + ContravarToContravarHomSetRep obj hom (a, b) -> HomSetRep obj hom (a, b) + HSRContravarToCovar : + ContravarToCovarHomSetRep obj hom (a, b) -> HomSetRep obj hom (a, b) + +public export +CovarHomHomRep : + (obj : Type) -> (hom : HomSlice obj) -> obj -> SliceObj obj +CovarHomHomRep obj hom = CovarToCovarHomSetRep obj hom .* MkPair + +public export +CovarHomHomSetRep : (obj : Type) -> (hom : HomSlice obj) -> obj -> Type +CovarHomHomSetRep obj hom = + Pi {a=obj} . CovarHomHomRep obj hom + +public export +CovarHomCatRep : (obj : Type) -> (hom : HomSlice obj) -> Type +CovarHomCatRep obj hom = + Pi {a=obj} $ CovarHomHomSetRep obj hom + +public export +CovarToContravarCatRep : (obj : Type) -> (hom : HomSlice obj) -> Type +CovarToContravarCatRep obj hom = + (a, b : obj) -> CovarToContravarHomSetRep obj hom (a, b) + +public export +ContravarHomHomRep : + (obj : Type) -> (hom : HomSlice obj) -> obj -> SliceObj obj +ContravarHomHomRep obj hom = ContravarToContravarHomSetRep obj hom .* MkPair + +public export +ContravarHomHomSetRep : (obj : Type) -> (hom : HomSlice obj) -> obj -> Type +ContravarHomHomSetRep obj hom = + Pi {a=obj} . ContravarHomHomRep obj hom + +public export +ContravarHomCatRep : (obj : Type) -> HomSlice obj -> Type +ContravarHomCatRep obj hom = + Pi {a=obj} $ ContravarHomHomSetRep obj hom + +public export +ContravarToCovarCatRep : (obj : Type) -> HomSlice obj -> Type +ContravarToCovarCatRep obj hom = + (a, b : obj) -> ContravarToCovarHomSetRep obj hom (a, b) + +public export +data YonedaHomSetRep : {obj : Type} -> HomSlice obj -> SliceObj obj where + YHSRCovar : CovarHomHomSetRep obj hom a -> YonedaHomSetRep {obj} hom a + YHSRContravar : ContravarHomHomSetRep obj hom a -> YonedaHomSetRep {obj} hom a + +public export +YonedaCatRep : {obj : Type} -> HomSlice obj -> Type +YonedaCatRep {obj} hom = Pi {a=obj} (YonedaHomSetRep {obj} hom) + +public export +CovarToCovarIdRep : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> CovarToCovarHomRep {obj} hom (a, a) +CovarToCovarIdRep {obj} {hom} a c = id {a=(hom (a, c))} + +public export +CovarToCovarComposeRep : {obj : Type} -> {hom : HomSlice obj} -> + {a, b, c : obj} -> + CovarToCovarHomRep {obj} hom (b, c) -> + CovarToCovarHomRep {obj} hom (a, b) -> + CovarToCovarHomRep {obj} hom (a, c) +CovarToCovarComposeRep {obj} {hom} {a} {b} {c} g f d = f d . g d + +public export +ContravarToContravarIdRep : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> ContravarToContravarHomRep {obj} hom (a, a) +ContravarToContravarIdRep {obj} {hom} a c = id {a=(hom (c, a))} + +public export +ContravarToContravarComposeRep : {obj : Type} -> {hom : HomSlice obj} -> + {a, b, c : obj} -> + ContravarToContravarHomRep {obj} hom (b, c) -> + ContravarToContravarHomRep {obj} hom (a, b) -> + ContravarToContravarHomRep {obj} hom (a, c) +ContravarToContravarComposeRep {obj} {hom} {a} {b} {c} g f d = g d . f d + +public export +CovarEqImpliesContravar : {obj : Type} -> {hom : HomSlice obj} -> + CovarHomCatRep obj hom -> ContravarHomCatRep obj hom -> Type +CovarEqImpliesContravar {obj} {hom} covar contravar = + {a, b : obj} -> (f, g : hom (a, b)) -> + CovarToCovarHomRepExtEq + {a} {b} {hom} (covar a b f) (covar a b g) -> + ContravarToContravarHomRepExtEq + {a} {b} {hom} (contravar a b f) (contravar a b g) + +public export +ContravarEqImpliesCovar : {obj : Type} -> {hom : HomSlice obj} -> + CovarHomCatRep obj hom -> ContravarHomCatRep obj hom -> Type +ContravarEqImpliesCovar {obj} {hom} covar contravar = + {a, b : obj} -> (f, g : hom (a, b)) -> + ContravarToContravarHomRepExtEq + {a} {b} {hom} (contravar a b f) (contravar a b g) -> + CovarToCovarHomRepExtEq + {a} {b} {hom} (covar a b f) (covar a b g) + +------------------------------------ +---- Free-category Yoneda lemma ---- +------------------------------------ + +public export +FreeCovarHomYonedaR : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (f : SliceObj obj) -> + InternalNTFromCovarHom {obj} (FreeHomM obj hom) a f -> f a +FreeCovarHomYonedaR {obj} {hom} a f alpha = + alpha a $ chId {obj} hom a + +public export +FreeCovarHomYonedaL : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (f : SliceObj obj) -> + (fmap : (a, b : obj) -> hom (a, b) -> f a -> f b) -> + f a -> InternalNTFromCovarHom {obj} (FreeHomM obj hom) a f +FreeCovarHomYonedaL {obj} {hom} a f fmap fa b mab = + chFreeFMap fmap a b mab fa + +public export +FreeContravarHomYonedaR : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (f : SliceObj obj) -> + InternalNTFromContravarHom {obj} (FreeHomM obj hom) a f -> f a +FreeContravarHomYonedaR {obj} {hom} a f alpha = + alpha a $ chId {obj} hom a + +public export +FreeContravarHomYonedaL : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (f : SliceObj obj) -> + -- f is contravariant + (fmap : (a, b : obj) -> hom (a, b) -> f b -> f a) -> + f a -> InternalNTFromContravarHom {obj} (FreeHomM obj hom) a f +FreeContravarHomYonedaL {obj} {hom} a f fmap fa b mba = + chFreeFContramap fmap b a mba fa + +-------------------------------------------- +-------------------------------------------- +---- Category-spec-style Geb definition ---- +-------------------------------------------- +-------------------------------------------- + +--------------------------- +---- General utilities ---- +--------------------------- + +public export +data EMorphEitherF : + {obj : Type} -> {f : Type -> Type} -> + HomSlice obj -> + HomEndofunctor (TrEitherF f obj) where + MEV : {x, y : obj} -> + homv (x, y) -> EMorphEitherF {obj} {f} homv hom (TFV x, TFV y) + MEU : {x, y : TrEitherF f obj} -> + hom (x, y) -> EMorphEitherF {obj} {f} homv hom (x, y) + +public export +data EMorphTranslateF : + {obj : Type} -> {f : Type -> Type} -> + HomSlice obj -> HomSlice (TrEitherF f obj) -> + HomEndofunctor (TrEitherF f obj) where + MTE : + EMorphEitherF {obj} {f} homv hom (x, y) -> + EMorphTranslateF {obj} {f} homv hom carrier (x, y) + MTI : + (x : TrEitherF f obj) -> + EMorphTranslateF {obj} {f} homv hom carrier (x, x) + MTC : {x, y, z : TrEitherF f obj} -> + carrier (y, z) -> carrier (x, y) -> + EMorphTranslateF {obj} {f} homv hom carrier (x, z) + +public export +data EFreeMorphF : + {obj : Type} -> {f : Type -> Type} -> + HomSlice obj -> + HomEndofunctor (TrEitherF f obj) where + InM : + {x, y : TrEitherF f obj} -> + EMorphTranslateF {obj} {f} homv hom + (EFreeMorphF {obj} {f} homv hom) (x, y) -> + EFreeMorphF {obj} {f} homv hom (x, y) + +public export +FMI : + {obj : Type} -> {f : Type -> Type} -> + {homv : HomSlice obj} -> + {hom : HomSlice (TrEitherF f obj)} -> + (x : TrEitherF f obj) -> + EFreeMorphF homv hom (x, x) +FMI x = InM (MTI x) + +public export +FMC : + {obj : Type} -> {f : Type -> Type} -> + {homv : HomSlice obj} -> + {hom : HomSlice (TrEitherF f obj)} -> + {x, y, z : TrEitherF f obj} -> + EFreeMorphF homv hom (y, z) -> + EFreeMorphF homv hom (x, y) -> + EFreeMorphF homv hom (x, z) +FMC g f = InM (MTC g f) + +public export +FME : + {obj : Type} -> {f : Type -> Type} -> + {homv : HomSlice obj} -> + {hom : HomSlice (TrEitherF f obj)} -> + {x, y : TrEitherF f obj} -> + EMorphEitherF homv hom (x, y) -> + EFreeMorphF homv hom (x, y) +FME m = InM (MTE m) + +public export +FMV : + {obj : Type} -> {f : Type -> Type} -> + {homv : HomSlice obj} -> + {hom : HomSlice (TrEitherF f obj)} -> + {x, y : obj} -> + homv (x, y) -> + EFreeMorphF homv hom (TFV x, TFV y) +FMV m = FME (MEV m) + +public export +FMU : + {obj : Type} -> {f : Type -> Type} -> + {homv : HomSlice obj} -> + {hom : HomSlice (TrEitherF f obj)} -> + {x, y : TrEitherF f obj} -> + hom (x, y) -> + EFreeMorphF homv hom (x, y) +FMU m = FME (MEU m) + +public export +MorphDenoteExtendCovar : + (obj : Type) -> + (f : Type -> Type) -> + (homv : HomSlice obj) -> + (hom : HomSlice (TrEitherF f obj)) -> + Type +MorphDenoteExtendCovar obj f homv hom = + CovarHomCatRep obj homv -> + (a, b : TrEitherF f obj) -> hom (a, b) -> + ((c : TrEitherF f obj) -> + EMorphEitherF {obj} {f} homv hom (b, c) -> + EFreeMorphF {obj} {f} homv hom (a, c)) + +public export +MorphDenoteExtendContravar : + (obj : Type) -> + (f : Type -> Type) -> + (homv : HomSlice obj) -> + (hom : HomSlice (TrEitherF f obj)) -> + Type +MorphDenoteExtendContravar obj f homv hom = + ContravarHomCatRep obj homv -> + (a, b : TrEitherF f obj) -> hom (a, b) -> + ((c : TrEitherF f obj) -> + EMorphEitherF {obj} {f} homv hom (c, a) -> + EFreeMorphF {obj} {f} homv hom (c, b)) + +----------------------------------------------- +----------------------------------------------- +---- Specific free universal constructions ---- +----------------------------------------------- +----------------------------------------------- + +------------------------ +---- Initial object ---- +------------------------ + +-- The adjunction which can be used to define the initial object has the +-- following data: +-- +-- - Left category C: category being freely generated +-- - Right category D: terminal category +-- - Left functor L: constant functor to initial object (and identity +-- morphism on initial object) +-- - Right functor R: unique functor to terminal category +-- - R . L (D -> D): identity functor (on terminal category -- this is the +-- _only_ endofunctor on the terminal category) +-- - L . R (C -> C): constant functor which takes any object to initial object, +-- and any morphism to identity on initial object +-- - Unit (id -> R . L): identity natural transformation (the only +-- natural transformation on the only endofunctor on the terminal category) +-- - Counit (L . R -> id): component at B is unique morphism from initial +-- object to B +-- - Adjuncts: (Hom(L A, B) == Hom(A, R B), for A : D and B : C): +-- for all B : C, fromVoid(Void, B) is in bijection with Hom(1 : D, 1 : D), +-- which is (isomorphic to) Unit +-- - Left triangle identity: (counit . L) . (L . unit) = id(L): +-- expanded, for all A : D, counit(L(A)) . L(unit(A)) = id(L(A)) +-- (which goes from L(A) to L(A) in C via L(R(L(A)))): +-- fromVoid(Void, L(A)) . L(id(A)) = id(L(A)) +-- -- this reduces to fromVoid(Void, Void) . id(Void) = id(Void), +-- and from there to fromVoid(Void, Void) = id(Void) +-- - Right triangle identity: (R . counit) . (unit . R) = id(R): +-- expanded, for all B : C, R(counit(B)) . unit(R(B)) = id(R(B)) +-- (which goes from R(B) to R(B) in D via R(L(R(B)))): +-- id(1) . id(1) = id(1) +-- -- this reduces to id(1) = id(1), so it's not telling us anything new +-- (we could have concluded that from the category laws alone, or indeed by +-- reflexivity on the unique morphism in the terminal category) + +-- The functor which freely generates an initial object simply +-- generates one new object. +public export +data InitialObjF : (obj : Type) -> Type where + Obj0 : InitialObjF obj + +-- The initial object's universal morphisms come from the unit in the terminal +-- category -- which is to say, there aren't any! +public export +data InitialUnitF : {obj : Type} -> (hom : HomSlice obj) -> + SliceObj (obj, InitialObjF obj) where + +-- The right adjunct, which takes an object from the base category +-- (the only morphism in the other category, which is the terminal +-- category, is the identity morphism on its only object, so it is +-- an ignored parameter) and produces a unique morphism to it from +-- the initial object. +public export +data InitialRightAdj : {0 obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + SliceObj (InitialObjF obj, obj') where + InRAFrom0 : {obj, obj' : Type} -> {hom : SliceObj (obj, obj')} -> + (a : obj') -> InitialRightAdj {obj} {obj'} hom (Obj0, a) + +-- Extend a profunctor H : (Cop, C) -> Type. +public export +InitialExtendHom : {obj : Type} -> (hom : HomSlice obj) -> + HomSlice (TrEitherF InitialObjF obj) +InitialExtendHom {obj} hom (TFV x, TFV y) = + hom (x, y) +InitialExtendHom {obj} hom (TFV x, TFC yz) = + InitialUnitF {obj} hom (x, yz) +InitialExtendHom {obj} hom (TFC xy, TFV z) = + InitialRightAdj {obj} {obj'=obj} hom (xy, z) +InitialExtendHom {obj} hom (TFC xy, TFC xy') = + InitialRightAdj {obj} {obj'=(InitialObjF obj)} + (InitialUnitF {obj} hom) (xy, xy') + +public export +initialRAAfterUnit : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (b : InitialObjF obj) -> (c : obj) -> + (mbc : InitialRightAdj {obj} {obj'=obj} hom (b, c)) -> + InitialUnitF {obj} hom (a, b) -> + hom (a, c) +initialRAAfterUnit a Obj0 b (InRAFrom0 b) ma0 = case ma0 of _ impossible + +public export +initialPreCompRAA : {0 obj : Type} -> (hom : HomSlice obj) -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (b, c : obj) -> + hom (b, c) -> + InitialRightAdj {obj} {obj'=obj} hom (Obj0, b) -> + InitialRightAdj {obj} {obj'=obj} hom (Obj0, c) +initialPreCompRAA hom comp b c mbc (InRAFrom0 b) = InRAFrom0 c + +public export +initialUnitExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a : obj) -> (b : InitialObjF obj) -> + RelationOn (InitialUnitF hom (a, b)) +initialUnitExtendEq eq a b mab mab' = case mab of _ impossible + +public export +initialRightAdjExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a : InitialObjF obj) -> (b : obj) -> + RelationOn (InitialRightAdj hom (a, b)) +initialRightAdjExtendEq eq Obj0 b (InRAFrom0 b) (InRAFrom0 b) = Unit + +public export +initialRightAdjUnitExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a, b : InitialObjF obj) -> + RelationOn (InitialRightAdj {obj} {obj'=(InitialObjF obj)} + (InitialUnitF hom) (a, b)) +initialRightAdjUnitExtendEq eq Obj0 Obj0 (InRAFrom0 Obj0) g = + case g of InRAFrom0 Obj0 => Unit + +-- Extend equality. +public export +initialExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a, b : TrEitherF InitialObjF obj) -> + RelationOn (InitialExtendHom hom (a, b)) +initialExtendEq eq (TFV a) (TFV b) f g = + eq a b f g +initialExtendEq eq (TFV a) (TFC b) f g = + initialUnitExtendEq eq a b f g +initialExtendEq {hom} eq (TFC a) (TFV b) f g = + initialRightAdjExtendEq {hom} eq a b f g +initialExtendEq eq (TFC a) (TFC b) f g = + initialRightAdjUnitExtendEq {obj} {hom} eq a b f g + +-- Extend reduction. Returns Nothing if irreducible. +public export +initialExtendReduce : {obj : Type} -> {hom : HomSlice obj} -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (a, b, c : TrEitherF InitialObjF obj) -> + InitialExtendHom hom (b, c) -> + InitialExtendHom hom (a, b) -> + Maybe (InitialExtendHom hom (a, c)) +initialExtendReduce comp (TFV a) (TFV b) (TFV c) mbc mab = + Just $ comp mbc mab +initialExtendReduce comp a b (TFC c) mbc mab = + Nothing +initialExtendReduce comp (TFV a) (TFC b) (TFV c) mbc mab = + Just $ initialRAAfterUnit {hom} a b c mbc mab +initialExtendReduce comp (TFC Obj0) (TFC Obj0) (TFV c) + (InRAFrom0 c) (InRAFrom0 Obj0) = Just $ InRAFrom0 c +initialExtendReduce {hom} comp (TFC Obj0) (TFV b) (TFV c) mbc mab = + Just $ initialPreCompRAA hom comp b c mbc mab + +-- Extend composition. Returns CHComp if irreducible. +public export +initialExtendCompose : {obj : Type} -> {hom : HomSlice obj} -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (a, b, c : TrEitherF InitialObjF obj) -> + InitialExtendHom hom (b, c) -> + InitialExtendHom hom (a, b) -> + CatEitherF (InitialExtendHom hom) (a, c) +initialExtendCompose comp a b c mbc mab with + (initialExtendReduce comp a b c mbc mab) + initialExtendCompose comp a b c mbc mab | Just mac = InSlV mac + initialExtendCompose comp a b c mbc mab | Nothing = CEcomp mbc mab + +-- Extend object interpretation. +public export +InitialInterpObj : {obj : Type} -> SliceObj obj -> SliceObj (InitialObjF obj) +InitialInterpObj interp Obj0 = Void + +public export +ExtendInitialInterpObj : {obj : Type} -> + SliceObj obj -> SliceObj (TrEitherF InitialObjF obj) +ExtendInitialInterpObj = sliceTrMap InitialInterpObj + +public export +initialInterpUnit : {obj : Type} -> (hom : HomSlice obj) -> + (ointerp : SliceObj obj) -> + (minterp : (a, b : obj) -> hom (a, b) -> ointerp a -> ointerp b) -> + (a : obj) -> (b : InitialObjF obj) -> + InitialUnitF hom (a, b) -> + ointerp a -> InitialInterpObj {obj} ointerp b +initialInterpUnit hom ointerp minterp a Obj0 f = case f of _ impossible + +public export +initialInterpRightAdj : {obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + (ointerp : SliceObj obj) -> + (ointerp' : SliceObj obj') -> + (minterp : + (a : obj) -> (b : obj') -> hom (a, b) -> ointerp a -> ointerp' b) -> + (a : InitialObjF obj) -> (b : obj') -> + InitialRightAdj {obj} {obj'} hom (a, b) -> + InitialInterpObj {obj} ointerp a -> + ointerp' b +initialInterpRightAdj hom ointerp ointerp' minterp Obj0 b f = voidF (ointerp' b) + +public export +ExtendInitialInterpMorph : {obj : Type} -> (hom : HomSlice obj) -> + (ointerp : SliceObj obj) -> + (minterp : (a, b : obj) -> hom (a, b) -> ointerp a -> ointerp b) -> + (a, b : TrEitherF InitialObjF obj) -> + InitialExtendHom {obj} hom (a, b) -> + ExtendInitialInterpObj {obj} ointerp a -> + ExtendInitialInterpObj {obj} ointerp b +ExtendInitialInterpMorph hom ointerp minterp (TFV a) (TFV b) + f = minterp a b f +ExtendInitialInterpMorph hom ointerp minterp (TFV a) (TFC b) mab = + initialInterpUnit hom ointerp minterp a b mab +ExtendInitialInterpMorph {obj} hom ointerp minterp (TFC a) (TFV b) adj = + initialInterpRightAdj {obj} {obj'=obj} + hom + ointerp + ointerp + minterp + a + b + adj +ExtendInitialInterpMorph {obj} hom ointerp minterp (TFC a) (TFC b) adj = + initialInterpRightAdj {obj} {obj'=(InitialObjF obj)} + (InitialUnitF hom) + ointerp + (InitialInterpObj ointerp) + (initialInterpUnit hom ointerp minterp) + a + b + adj + +------------------------- +---- Terminal object ---- +------------------------- + +public export +data TerminalObjF : (obj : Type) -> Type where + Obj1 : TerminalObjF obj + +-- The terminal object's universal morphisms come from the counit in the +-- terminal category -- which is to say, there aren't any! +public export +data TerminalCounitF : {obj : Type} -> (hom : HomSlice obj) -> + SliceObj (obj, TerminalObjF obj) where + +-- The left adjunct, which takes an object from the base category +-- (the only morphism in the other category, which is the terminal +-- category, is the identity morphism on its only object, so it is +-- an ignored parameter) and produces a unique morphism from it from +-- the terminal object. +public export +data TerminalLeftAdj : {0 obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + SliceObj (obj, TerminalObjF obj') where + InLATo1 : {obj, obj' : Type} -> {hom : SliceObj (obj, obj')} -> + (a : obj) -> TerminalLeftAdj {obj} {obj'} hom (a, Obj1) + +-------------------- +---- Coproducts ---- +-------------------- + +-- The adjunction which can be used to define the coproduct has the +-- following data: +-- +-- - Left category C: category being freely generated +-- - Right category D: product category of category being freely generated +-- - Left functor L: functor from (A, A') to A + A' +-- - Right functor R: diagonal functor (A to (A, A)) +-- - R . L (D -> D): (A, A') -> (A + A', A + A') +-- - L . R (C -> C): A -> A + A +-- - Unit (id -> R . L): (A, A') -> (A + A', A + A'): injections +-- (A -> A + A' and A' -> A + A'), which are the introduction rules +-- - Counit (L . R -> id): A + A -> A: codiagonal +-- (`Left x` and `Right x` both go to `x`) +-- - Adjuncts: (Hom(L A, B) == Hom(A, R B), for A : D and B : C): +-- for all (A, A', B) : C, Hom(A + A', B) == Hom((A, A'), (B, B)): +-- that is, a morphism A + A' -> B is equivalent to a pair of morphisms +-- A -> B and A' -> B (the right adjunct is therefore the elimination rule, +-- AKA a case statement) +-- - Left triangle identity: (counit . L) . (L . unit) = id(L): +-- expanded, for all A : D, counit(L(A)) . L(unit(A)) = id(L(A)) +-- (which goes from L(A) to L(A) in C via L(R(L(A)))): +-- this becomes: +-- forall A, A' : C, +-- ((A + A') + (A + A') -> (A + A')) . (A + A' -> (A + A') + (A + A')) == +-- id(A + A') -- so if we start at A + A', inject to each side of the +-- coproduct with itself, and then take the codiagonal, we get the +-- same thing back that we started with +-- - Right triangle identity: (R . counit) . (unit . R) = id(R): +-- expanded, for all B : C, R(counit(B)) . unit(R(B)) = id(R(B)) +-- (which goes from R(B) to R(B) in D via R(L(R(B)))): +-- this becomes: +-- forall B : C, +-- ((B + B) -> B, (B + B) -> B) . (B -> B + B, B -> B + B) == id(B, B) +-- this ends up implying two identities: +-- codiag . linj(B -> B + B) = id +-- codiag . rinj(B -> B + B) = id +-- The left triangle identity appears to me to be just a more convoluted +-- version of this, so this right identity is the "useful" one for this +-- adjunction. +-- Is it the case that we can conclude from this by using bimap in +-- the diagonal category that: +-- elim(f : A -> C, g : B -> C) . linj(A, B) = f +-- elim(f : A -> C, g : B -> C) . rinj(A, B) = g +-- +-- -- Laws from _Generic Programming With Adjunctions_ (see Table 1): +-- +-- - Adjuncts viewed from the left : +-- Hom (A + A', B) <-> Hom((A, A'), (B, B)) +-- gives an elimination rule for coproducts +-- - Universal property: +-- for all (A, A') : D (equivalently, all A, A' : D), B : C, +-- f : C((A + A') -> B), g : D((A, A') -> (B, B)) (equivalently, +-- all g1 : A -> B, g2 : A' -> B): +-- f = radj(g) <=> ladj(f) = g +-- With signatures spelled out, that's: +-- f : (A + A') -> B = radj(g) <=> +-- ladj(f) : (A, A') -> (B, B) = g <=> +-- ((morph1(ladj(f)) : A -> B == g1) && (morph2(ladj(f)) : A' -> B == g2)) +-- - reflection law / simple computation law (eta/beta reductions, or +-- (co)unit/adjunct correspondence): +-- counit = radj(id) : spelled out, for all A : C, +-- codiag(A) : A + A -> A = radj(id(A), id(A)) +-- unit = ladj(id) : spelled out, for all A, A' : C, +-- inj : (A, A') -> (A + A', A + A') = ladj(id(A + A')) +-- - Computation (from left, eta reduction rule): +-- f = radj(ladj(f)) : spelled out, for all A, A', B : C, +-- f : A + A' -> B == radj(morph1(ladj(f)), morph2(ladj(f))) +-- - Computation (from right, beta reduction rule): +-- g = ladj(radj(g)) : spelled out, for all A, A', B : C, +-- (g : A -> B, g' : A' -> B) == ladj(radj(g, g')) <=> +-- (g = morph1(ladj(radj(g, g')))) && (g' = morph2(ladj(radj(g, g')))) +-- - Functor fusion law from left: +-- radj(g) . L h == radj(g . h) +-- - Fusion law from right: +-- ladj(f) . h == ladj(f . L h) +-- - Fusion law from left: +-- k . radj(g) == radj(R k . g) +-- - Functor fusion law from right: +-- R k . ladj(f) == ladj(k . f) +-- - Counit naturality: +-- k . counit == counit . (L(R(k))) +-- - Unit naturality: +-- R(L(h)) . unit == unit . h + +public export +data CoprodObjF : (obj : Type) -> Type where + ObjCp : obj -> obj -> CoprodObjF obj + +-- The coproduct's universal morphisms come from the unit in the product +-- category. +public export +data CoprodUnitF : {obj : Type} -> (hom : HomSlice obj) -> + SliceObj (obj, CoprodObjF obj) where + CpUnInjL : (x, y : obj) -> + CoprodUnitF {obj} hom (x, ObjCp x y) + CpUnInjR : (x, y : obj) -> + CoprodUnitF {obj} hom (y, ObjCp x y) + +-- The right adjunct, which takes two morphisms -- i.e., a morphism in +-- the product category -- and produces one in the base category. +public export +data CoprodRightAdj : {0 obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + SliceObj (CoprodObjF obj, obj') where + CpRACase : {0 obj, obj' : Type} -> {0 a, b : obj} -> {0 c : obj'} -> + {hom : (obj, obj') -> Type} -> + hom (a, c) -> hom (b, c) -> + CoprodRightAdj {obj} {obj'} hom (ObjCp a b, c) + +-- Extend a profunctor H : (Cop, C) -> Type. +public export +CoprodExtendHom : {obj : Type} -> (hom : HomSlice obj) -> + HomSlice (TrEitherF CoprodObjF obj) +CoprodExtendHom {obj} hom (TFV x, TFV y) = + hom (x, y) +CoprodExtendHom {obj} hom (TFV x, TFC yz) = + CoprodUnitF {obj} hom (x, yz) +CoprodExtendHom {obj} hom (TFC xy, TFV z) = + CoprodRightAdj {obj} {obj'=obj} hom (xy, z) +CoprodExtendHom {obj} hom (TFC xy, TFC xy') = + CoprodRightAdj {obj} {obj'=(CoprodObjF obj)} (CoprodUnitF {obj} hom) (xy, xy') + +public export +coprodRAAfterUnit : {obj : Type} -> {hom : HomSlice obj} -> + (a : obj) -> (b : CoprodObjF obj) -> (c : obj) -> + (mbc : CoprodRightAdj {obj} {obj'=obj} hom (b, c)) -> + CoprodUnitF {obj} hom (a, b) -> + hom (a, c) +coprodRAAfterUnit a (ObjCp a b) c (CpRACase f g) (CpUnInjL a b) = f +coprodRAAfterUnit b (ObjCp a b) c (CpRACase f g) (CpUnInjR a b) = g + +public export +coprodPreCompRAA : {0 obj : Type} -> (hom : HomSlice obj) -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (a, a', b, c : obj) -> + hom (b, c) -> + CoprodRightAdj {obj} {obj'=obj} hom (ObjCp a a', b) -> + CoprodRightAdj {obj} {obj'=obj} hom (ObjCp a a', c) +coprodPreCompRAA {obj} hom comp a a' b c mbc (CpRACase mab ma'b) = + CpRACase {obj} {obj'=obj} {a} {b=a'} {c} + (comp {a} {b} {c} mbc mab) + (comp {a=a'} {b} {c} mbc ma'b) + +public export +coprodPostCompUnit : {obj : Type} -> (hom : HomSlice obj) -> + (a, a', b, b', c : obj) -> + CoprodRightAdj hom (ObjCp b b', c) -> + CoprodUnitF {obj} hom (a, ObjCp b b') -> + CoprodUnitF {obj} hom (a', ObjCp b b') -> + CoprodRightAdj {obj} {obj'=obj} hom (ObjCp a a', c) +coprodPostCompUnit {obj} hom a a' b b' c mbc mab ma'b = + CpRACase {obj} {obj'=obj} {a} {b=a'} {c} + (coprodRAAfterUnit a (ObjCp b b') c mbc mab) + (coprodRAAfterUnit a' (ObjCp b b') c mbc ma'b) + +public export +coprodUnitExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a : obj) -> (b : CoprodObjF obj) -> + RelationOn (CoprodUnitF hom (a, b)) +coprodUnitExtendEq eq a (ObjCp a b) (CpUnInjL a b) (CpUnInjL a b) = Unit +coprodUnitExtendEq eq a (ObjCp a a) (CpUnInjL a a) (CpUnInjR a a) = Void +coprodUnitExtendEq eq a (ObjCp a a) (CpUnInjR a a) (CpUnInjL a a) = Void +coprodUnitExtendEq eq b (ObjCp a b) (CpUnInjR a b) (CpUnInjR a b) = Unit + +public export +coprodRightAdjExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a : CoprodObjF obj) -> (b : obj) -> + RelationOn (CoprodRightAdj hom (a, b)) +coprodRightAdjExtendEq eq (ObjCp a a') b (CpRACase f g) (CpRACase f' g') = + Pair (eq a b f f') (eq a' b g g') + +public export +coprodRightAdjUnitExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a, b : CoprodObjF obj) -> + RelationOn (CoprodRightAdj {obj} {obj'=(CoprodObjF obj)} + (CoprodUnitF hom) (a, b)) +coprodRightAdjUnitExtendEq eq (ObjCp a a') b (CpRACase f g) (CpRACase f' g') = + Pair + (coprodUnitExtendEq {hom} eq a b f f') + (coprodUnitExtendEq {hom} eq a' b g g') + +-- Extend equality. +public export +coprodExtendEq : {obj : Type} -> {hom : HomSlice obj} -> + (eq : (0 a, b : obj) -> RelationOn (hom (a, b))) -> + (a, b : TrEitherF CoprodObjF obj) -> + RelationOn (CoprodExtendHom hom (a, b)) +coprodExtendEq eq (TFV a) (TFV b) f g = + eq a b f g +coprodExtendEq eq (TFV a) (TFC b) f g = + coprodUnitExtendEq eq a b f g +coprodExtendEq {hom} eq (TFC a) (TFV b) f g = + coprodRightAdjExtendEq {hom} eq a b f g +coprodExtendEq eq (TFC a) (TFC b) f g = + coprodRightAdjUnitExtendEq {obj} {hom} eq a b f g + +-- Extend reduction. Returns Nothing if irreducible. +public export +coprodExtendReduce : {obj : Type} -> {hom : HomSlice obj} -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (a, b, c : TrEitherF CoprodObjF obj) -> + CoprodExtendHom hom (b, c) -> + CoprodExtendHom hom (a, b) -> + Maybe (CoprodExtendHom hom (a, c)) +coprodExtendReduce comp (TFV a) (TFV b) (TFV c) mbc mab = + Just $ comp mbc mab +coprodExtendReduce comp a b (TFC c) mbc mab = + Nothing +coprodExtendReduce comp (TFV a) (TFC b) (TFV c) mbc mab = + Just $ coprodRAAfterUnit {hom} a b c mbc mab +coprodExtendReduce comp (TFC (ObjCp a a')) (TFC (ObjCp b b')) (TFV c) + mbb'c (CpRACase {a} {b=a'} {c=(ObjCp b b')} mabb' ma'bb') = + Just $ coprodPostCompUnit hom a a' b b' c mbb'c mabb' ma'bb' +coprodExtendReduce {hom} comp (TFC (ObjCp a a')) (TFV b) (TFV c) mbc mab = + Just $ coprodPreCompRAA hom comp a a' b c mbc mab + +-- Extend composition. Returns CHComp if irreducible. +public export +coprodExtendCompose : {obj : Type} -> {hom : HomSlice obj} -> + (comp : {0 a, b, c : obj} -> hom (b, c) -> hom (a, b) -> hom (a, c)) -> + (a, b, c : TrEitherF CoprodObjF obj) -> + CoprodExtendHom hom (b, c) -> + CoprodExtendHom hom (a, b) -> + CatEitherF (CoprodExtendHom hom) (a, c) +coprodExtendCompose comp a b c mbc mab with + (coprodExtendReduce comp a b c mbc mab) + coprodExtendCompose comp a b c mbc mab | Just mac = InSlV mac + coprodExtendCompose comp a b c mbc mab | Nothing = CEcomp mbc mab + +-- Extend object interpretation. +public export +CoprodInterpObj : {obj : Type} -> SliceObj obj -> SliceObj (CoprodObjF obj) +CoprodInterpObj interp (ObjCp x y) = Either (interp x) (interp y) + +public export +ExtendCoprodInterpObj : {obj : Type} -> + SliceObj obj -> SliceObj (TrEitherF CoprodObjF obj) +ExtendCoprodInterpObj = sliceTrMap CoprodInterpObj + +public export +coprodInterpUnit : {obj : Type} -> (hom : HomSlice obj) -> + (ointerp : SliceObj obj) -> + (minterp : (a, b : obj) -> hom (a, b) -> ointerp a -> ointerp b) -> + (a : obj) -> (b : CoprodObjF obj) -> + CoprodUnitF hom (a, b) -> + ointerp a -> CoprodInterpObj {obj} ointerp b +coprodInterpUnit hom ointerp minterp a (ObjCp a b) (CpUnInjL a b) = Left +coprodInterpUnit hom ointerp minterp b (ObjCp a b) (CpUnInjR a b) = Right + +public export +coprodInterpRightAdj : {obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + (ointerp : SliceObj obj) -> + (ointerp' : SliceObj obj') -> + (minterp : + (a : obj) -> (b : obj') -> hom (a, b) -> ointerp a -> ointerp' b) -> + (a : CoprodObjF obj) -> (b : obj') -> + CoprodRightAdj {obj} {obj'} hom (a, b) -> + CoprodInterpObj {obj} ointerp a -> + ointerp' b +coprodInterpRightAdj hom ointerp ointerp' minterp + (ObjCp a a') b (CpRACase f g) = + eitherElim (minterp a b f) (minterp a' b g) + +public export +ExtendCoprodInterpMorph : {obj : Type} -> (hom : HomSlice obj) -> + (ointerp : SliceObj obj) -> + (minterp : (a, b : obj) -> hom (a, b) -> ointerp a -> ointerp b) -> + (a, b : TrEitherF CoprodObjF obj) -> + CoprodExtendHom {obj} hom (a, b) -> + ExtendCoprodInterpObj {obj} ointerp a -> + ExtendCoprodInterpObj {obj} ointerp b +ExtendCoprodInterpMorph hom ointerp minterp (TFV a) (TFV b) + f = minterp a b f +ExtendCoprodInterpMorph hom ointerp minterp (TFV a) (TFC b) mab = + coprodInterpUnit hom ointerp minterp a b mab +ExtendCoprodInterpMorph {obj} hom ointerp minterp (TFC a) (TFV b) adj = + coprodInterpRightAdj {obj} {obj'=obj} + hom + ointerp + ointerp + minterp + a + b + adj +ExtendCoprodInterpMorph {obj} hom ointerp minterp (TFC a) (TFC b) adj = + coprodInterpRightAdj {obj} {obj'=(CoprodObjF obj)} + (CoprodUnitF hom) + ointerp + (CoprodInterpObj ointerp) + (coprodInterpUnit hom ointerp minterp) + a + b + adj + +------------------ +---- Products ---- +------------------ + +public export +data ProdObjF : (obj : Type) -> Type where + ObjPr : obj -> obj -> ProdObjF obj + +-- The product's universal morphisms come from the counit in the product +-- category. +public export +data ProdCounitF : {obj : Type} -> (hom : HomSlice obj) -> + SliceObj (ProdObjF obj, obj) where + PrCoProjL : (x, y : obj) -> + ProdCounitF {obj} hom (ObjPr x y, x) + PrCoProjR : (x, y : obj) -> + ProdCounitF {obj} hom (ObjPr x y, y) + +-- The left adjunct, which takes two morphisms -- i.e., a morphism in +-- the product category -- and produces one in the base category. +public export +data ProdLeftAdj : {0 obj, obj' : Type} -> (hom : SliceObj (obj, obj')) -> + SliceObj (obj, ProdObjF obj') where + PrLABi : {0 obj, obj' : Type} -> {0 a, b : obj'} -> {0 c : obj} -> + {hom : (obj, obj') -> Type} -> + hom (c, a) -> hom (c, b) -> + ProdLeftAdj {obj} {obj'} hom (c, ObjPr a b) + +--------------------------------------------------- +--------------------------------------------------- +---- Yoneda categories with explicit coherence ---- +--------------------------------------------------- +--------------------------------------------------- + +public export +record YCat where + constructor YC + ycObj : Type + ycHom : HomSlice ycObj + 0 ycDenoteCovar : CovarHomCatRep ycObj ycHom + 0 ycDenoteContravar : ContravarHomCatRep ycObj ycHom + +public export +YCHomSlice : YCat -> Type +YCHomSlice yc = HomSlice (ycObj yc) + +public export +YCovarNT : (yc : YCat) -> YCHomSlice yc +YCovarNT yc = CovarToCovarHomRep {obj=(ycObj yc)} (ycHom yc) + +public export +YContravarNT : (yc : YCat) -> YCHomSlice yc +YContravarNT yc = ContravarToContravarHomRep {obj=(ycObj yc)} (ycHom yc) + +public export +yIdCovar : (yc : YCat) -> (x : ycObj yc) -> YCovarNT yc (x, x) +yIdCovar yc = CovarToCovarIdRep {obj=(ycObj yc)} {hom=(ycHom yc)} + +public export +yIdContravar : (yc : YCat) -> (x : ycObj yc) -> YContravarNT yc (x, x) +yIdContravar yc = ContravarToContravarIdRep {obj=(ycObj yc)} {hom=(ycHom yc)} + +public export +yComposeCovar : {yc : YCat} -> {a, b, c: ycObj yc} -> + YCovarNT yc (b, c) -> YCovarNT yc (a, b) -> YCovarNT yc (a, c) +yComposeCovar {yc} = + CovarToCovarComposeRep {obj=(ycObj yc)} {hom=(ycHom yc)} + +public export +yComposeContravar : {yc : YCat} -> {a, b, c: ycObj yc} -> + YContravarNT yc (b, c) -> YContravarNT yc (a, b) -> YContravarNT yc (a, c) +yComposeContravar {yc} = + ContravarToContravarComposeRep {obj=(ycObj yc)} {hom=(ycHom yc)} + +public export +YExtendObjF : Type +YExtendObjF = YCat -> Type + +-- Just an explicit name for `Coprod(ycObj, oext)`. +public export +data YExtendedObj : YCat -> YExtendObjF -> Type where + EOV : ycObj yc -> YExtendedObj yc oext + EOU : oext yc -> YExtendedObj yc oext + +public export +YExtendMorphF : YExtendObjF -> Type +YExtendMorphF oext = (yc : YCat) -> HomSlice (YExtendedObj yc oext) + +public export +YExtendMorphCovarDenote : {oext : YExtendObjF} -> YExtendMorphF oext -> Type +YExtendMorphCovarDenote {oext} mext = + (yc : YCat) -> (x, y : YExtendedObj yc oext) -> mext yc (x, y) -> + CovarToCovarHomSetRep (YExtendedObj yc oext) (mext yc) (x, y) + +public export +YExtendMorphContravarDenote : {oext : YExtendObjF} -> YExtendMorphF oext -> Type +YExtendMorphContravarDenote {oext} mext = + (yc : YCat) -> (x, y : YExtendedObj yc oext) -> mext yc (x, y) -> + ContravarToContravarHomSetRep (YExtendedObj yc oext) (mext yc) (x, y) + +public export +data YExtendedMorph : + YCat -> (oext : YExtendObjF) -> YExtendMorphF oext -> + HomSlice (YExtendedObj yc oext) where + EMV : {0 oext : YExtendObjF} -> {0 mext : YExtendMorphF oext} -> + {0 x, y : ycObj yc} -> + ycHom yc (x, y) -> YExtendedMorph yc oext mext (EOV {yc} x, EOV {yc} y) + EMU : {0 oext : YExtendObjF} -> {0 mext : YExtendMorphF oext} -> + {0 x, y : YExtendedObj yc oext} -> + mext yc (x, y) -> YExtendedMorph yc oext mext (x, y) + +public export +YExtendCovarDenotation : {oext : YExtendObjF} -> YExtendMorphF oext -> Type +YExtendCovarDenotation {oext} mext = + (yc : YCat) -> (x, y : YExtendedObj yc oext) -> + YExtendedMorph yc oext mext (x, y) -> + CovarToCovarHomSetRep + (YExtendedObj yc oext) (YExtendedMorph yc oext mext) (x, y) + +public export +YExtendContravarDenotation : {oext : YExtendObjF} -> YExtendMorphF oext -> Type +YExtendContravarDenotation {oext} mext = + (yc : YCat) -> (x, y : YExtendedObj yc oext) -> + YExtendedMorph yc oext mext (x, y) -> + ContravarToContravarHomSetRep + (YExtendedObj yc oext) (YExtendedMorph yc oext mext) (x, y) + +------------------------------------------------ +---- Free categories from Yoneda categories ---- +------------------------------------------------ + +public export +YObjHomSlice : (yc : YCat) -> Type +YObjHomSlice yc = HomSlice yc.ycObj + +public export +YCatFreeHomSlice : (yc : YCat) -> YObjHomSlice yc +YCatFreeHomSlice yc = FreeHomM yc.ycObj yc.ycHom + +public export +ycId : (yc : YCat) -> (a : yc.ycObj) -> YCatFreeHomSlice yc (a, a) +ycId yc a = chId (yc.ycHom) a + +public export +ycComp : (yc : YCat) -> {a, b, c : yc.ycObj} -> + YCatFreeHomSlice yc (b, c) -> YCatFreeHomSlice yc (a, b) -> + YCatFreeHomSlice yc (a, c) +ycComp yc {a} {b} {c} g f = chComp g f + +public export +YCHomSliceCata : YCat -> Type +YCHomSliceCata yc = HomSliceCata yc.ycObj + +public export +ycHomSliceCata : (yc : YCat) -> (sa : HomSlice yc.ycObj) -> + SliceMorphism yc.ycHom sa -> SliceAlg CatHomF sa -> + SliceMorphism (SliceFreeM CatHomF yc.ycHom) sa +ycHomSliceCata yc = homSliceCata {obj=yc.ycObj} yc.ycHom + +------------------------------------------- +---- Free-Yoneda-category Yoneda lemma ---- +------------------------------------------- + +public export +ycFreeFMap : {yc : YCat} -> {f : SliceObj yc.ycObj} -> + ((a, b : yc.ycObj) -> yc.ycHom (a, b) -> f a -> f b) -> + ((a, b : yc.ycObj) -> YCatFreeHomSlice yc (a, b) -> f a -> f b) +ycFreeFMap {yc} {f} = chFreeFMap {obj=yc.ycObj} {hom=yc.ycHom} {f} + +public export +ycFreeFContramap : {yc : YCat} -> {f : SliceObj yc.ycObj} -> + ((a, b : yc.ycObj) -> yc.ycHom (a, b) -> f b -> f a) -> + ((a, b : yc.ycObj) -> YCatFreeHomSlice yc (a, b) -> f b -> f a) +ycFreeFContramap {yc} {f} = chFreeFContramap {obj=yc.ycObj} {hom=yc.ycHom} {f} + +public export +YCCovarHomYonedaR : + (yc : YCat) -> (a : yc.ycObj) -> (f : SliceObj yc.ycObj) -> + InternalNTFromCovarHom {obj=yc.ycObj} (YCatFreeHomSlice yc) a f -> f a +YCCovarHomYonedaR yc = FreeCovarHomYonedaR {obj=yc.ycObj} {hom=yc.ycHom} + +public export +YCCovarHomYonedaL : (yc : YCat) -> (a : yc.ycObj) -> (f : SliceObj yc.ycObj) -> + (fmap : (a, b : yc.ycObj) -> yc.ycHom (a, b) -> f a -> f b) -> + f a -> InternalNTFromCovarHom {obj=yc.ycObj} (YCatFreeHomSlice yc) a f +YCCovarHomYonedaL yc = FreeCovarHomYonedaL {obj=yc.ycObj} {hom=yc.ycHom} + +public export +YCContravarHomYonedaR : + (yc : YCat) -> (a : yc.ycObj) -> (f : SliceObj yc.ycObj) -> + InternalNTFromContravarHom {obj=yc.ycObj} (YCatFreeHomSlice yc) a f -> f a +YCContravarHomYonedaR yc = FreeContravarHomYonedaR {obj=yc.ycObj} {hom=yc.ycHom} + +public export +YCContravarHomYonedaL : + (yc : YCat) -> (a : yc.ycObj) -> (f : SliceObj yc.ycObj) -> + -- f is contravariant + (fmap : (a, b : yc.ycObj) -> yc.ycHom (a, b) -> f b -> f a) -> + f a -> InternalNTFromContravarHom {obj=yc.ycObj} (YCatFreeHomSlice yc) a f +YCContravarHomYonedaL yc = FreeContravarHomYonedaL {obj=yc.ycObj} {hom=yc.ycHom} + +-------------------------------------------------------- +---- Free Yoneda categories are standard categories ---- +-------------------------------------------------------- + +public export +ycEqRel : (yc : YCat) -> (0 a, b : yc.ycObj) -> + RelationOn (YCatFreeHomSlice yc (a, b)) +ycEqRel yc a b (InSlF (a, b) (InSlV v)) (InSlF (a, b) (InSlV v')) = + ?ycEqRel_hole_vv +ycEqRel yc a b (InSlF (a, b) (InSlV v)) (InSlF (a, b) (InSlC m')) = + ?ycEqRel_hole_vc +ycEqRel yc a b (InSlF (a, b) (InSlC m)) (InSlF (a, b) (InSlV v')) = + ?ycEqRel_hole_cv +ycEqRel yc a b (InSlF (a, b) (InSlC m)) (InSlF (a, b) (InSlC m')) = + ?ycEqRel_hole_cc + +public export +ycEqRelRefl : (yc : YCat) -> (0 a, b : yc.ycObj) -> + IsReflexive (ycEqRel yc a b) +ycEqRelRefl yc a b = ?ycEqRelRefl_hole + +public export +ycEqRelSym : (yc : YCat) -> (0 a, b : yc.ycObj) -> + IsSymmetric (ycEqRel yc a b) +ycEqRelSym yc a b = ?ycEqRelSym_hole + +public export +ycEqRelTrans : (yc : YCat) -> (0 a, b : yc.ycObj) -> + IsTransitive (ycEqRel yc a b) +ycEqRelTrans yc a b = ?ycEqRelTrans_hole + +public export +ycEqRelEquiv : (yc : YCat) -> (0 a, b : yc.ycObj) -> + IsEquivalence (ycEqRel yc a b) +ycEqRelEquiv yc a b = + MkEquivalence + ?ycEqRelRefl_equiv_hole + ?ycEqRelSym_equiv_hole + ?ycEqRelTrans_equiv_hole + +public export +ycEq : (yc : YCat) -> (sig : SignatureT yc.ycObj) -> + EqRel (YCatFreeHomSlice yc sig) +ycEq yc (a, b) = MkEq (ycEqRel yc a b) (ycEqRelEquiv yc a b) + +public export +0 ycIdL : (yc : YCat) -> {0 a, b : yc.ycObj} -> + (f : YCatFreeHomSlice yc (a, b)) -> + (ycEq yc (a, b)).eqRel f (ycComp yc {a} {b} {c=b} (ycId yc b) f) +ycIdL yc {a} {b} f = ?ycIdL_hole + +public export +0 ycIdR : (yc : YCat) -> {0 a, b : yc.ycObj} -> + (f : YCatFreeHomSlice yc (a, b)) -> + (ycEq yc (a, b)).eqRel f (ycComp yc {a} {b=a} {c=b} f (ycId yc a)) +ycIdR yc {a} {b} f = ?ycIdR_hole + +public export +0 ycAssoc : (yc : YCat) -> {0 a, b, c, d : yc.ycObj} -> + (f : YCatFreeHomSlice yc (a, b)) -> (g : YCatFreeHomSlice yc (b, c)) -> + (h : YCatFreeHomSlice yc (c, d)) -> + (ycEq yc (a, d)).eqRel + (ycComp yc {a} {b=c} {c=d} h (ycComp yc {a} {b} {c} g f)) + (ycComp yc {a} {b} {c=d} (ycComp yc {a=b} {b=c} {c=d} h g) f) +ycAssoc yc {a} {b} {c} {d} f g h = ?ycAssoc_hole + +public export +YCatToSCat : YCat -> SCat +YCatToSCat yc = + SC + yc.ycObj + (YCatFreeHomSlice yc) + (ycId yc) + (ycComp yc) + (ycEq yc) + (ycIdL yc) + (ycIdR yc) + (ycAssoc yc) + +--------------------------------------------------- +---- Standard categories are Yoneda categories ---- +--------------------------------------------------- + +public export +SCatCovarDenotation : (sc : SCat) -> CovarHomCatRep sc.scObj sc.scHom +SCatCovarDenotation sc a b mab c mbc = sc.scComp mbc mab + +public export +SCatContravarDenotation : (sc : SCat) -> ContravarHomCatRep sc.scObj sc.scHom +SCatContravarDenotation sc a b mab c mca = sc.scComp mab mca + +public export +SCatToYCat : SCat -> YCat +SCatToYCat sc = + YC + sc.scObj + sc.scHom + (SCatCovarDenotation sc) + (SCatContravarDenotation sc) + +---------------------------------------------------------------------------- +---- Yoneda <-> standard formulations of category theory are equivalent ---- +---------------------------------------------------------------------------- + +-- This still needs to be proven. It will depend upon the slice-category +-- free monad's properties, such as its being Cartesian and idempotent. +-- The claim of the equivalence is that YCatToSCat |- SCatToYCatCovar +-- and YCatToSCat |- SCatToYCatContravar are both adjunctions (so in particular +-- SCatToYCatCovar and SCatToYCatContravar are naturally isomorphic) between +-- the category of Yoneda categories and the category of standard categories, +-- and the counit (in the category of standard categories) is a natural +-- isomorphism (up to categorical equivalence). +-- +-- Note that this is an enhancement of the free-forgetful adjunction between +-- the category of diagrams and the category of (standard) categories. +-- The "Yoneda category" extends the notion of a diagram with an embedding +-- of the edges into internal natural transformations of the metalanguage, +-- which amount to a way of assigning free equalities to paths in the diagram +-- without having explicitly to introduce identity or composition. + +--------------------------------------- +---- Coproducts as Yoneda category ---- +--------------------------------------- + +public export +YCoprodObj : YCat -> Type +YCoprodObj yc = ?YCoprodObj_hole + +public export +YCoprodHom : (yc : YCat) -> HomSlice (YCoprodObj yc) +YCoprodHom yc = ?YCoprodHom_hole + +public export +YCoprodCovarDenotation : (yc : YCat) -> + CovarHomCatRep (YCoprodObj yc) (YCoprodHom yc) +YCoprodCovarDenotation yc = ?YCoprodCovarDenotation_hole + +public export +YCoprodContravarDenotation : (yc : YCat) -> + ContravarHomCatRep (YCoprodObj yc) (YCoprodHom yc) +YCoprodContravarDenotation yc = ?YCoprodContravarDenotation_hole + +public export +YCoprodCovarEqImpliesContravar : (yc : YCat) -> + CovarEqImpliesContravar {obj=(YCoprodObj yc)} {hom=(YCoprodHom yc)} + (YCoprodCovarDenotation yc) (YCoprodContravarDenotation yc) +YCoprodCovarEqImpliesContravar yc = ?YCoprodCovarEqImpliesContravar_hole + +public export +YCoprodContravarEqImpliesCovar : (yc : YCat) -> + ContravarEqImpliesCovar {obj=(YCoprodObj yc)} {hom=(YCoprodHom yc)} + (YCoprodCovarDenotation yc) (YCoprodContravarDenotation yc) +YCoprodContravarEqImpliesCovar yc = ?YCoprodContravarEqImpliesCovar_hole + +public export +YCoprod : YCat -> YCat +YCoprod yc = + YC + (YCoprodObj yc) + (YCoprodHom yc) + (YCoprodCovarDenotation yc) + (YCoprodContravarDenotation yc) + +--------------------- +--------------------- +---- Experiments ---- +--------------------- +--------------------- + +public export +data XTypeF : (a : Type) -> (term : a -> Type) -> Type where + XT0 : XTypeF a term + XT1 : XTypeF a term + XTC : a -> a -> XTypeF a term + XTP : a -> a -> XTypeF a term + XTSig : (ty : a) -> (term ty -> a) -> XTypeF a term + +public export +XTermF : {a : Type} -> (term : a -> Type) -> XTypeF a term -> Type +XTermF term XT0 = Void +XTermF term XT1 = Unit +XTermF term (XTC ty ty') = Either (term ty) (term ty') +XTermF term (XTP ty ty') = Pair (term ty) (term ty') +XTermF term (XTSig ty pred) = DPair (term ty) (term . pred) + +mutual + public export + partial + data XType : Type where + InXT : XTypeF XType XTerm -> XType + + public export + partial + data XTerm : XType -> Type where + InXt : XTermF {a=XType} XTerm ty -> XTerm (InXT ty) + +mutual + public export + data XObj : Type where + XO1 : XObj + XOB : XObj + XOP : XObj -> XObj -> XObj + XOEq : {a, b : XObj} -> XMorph a b -> XMorph a b -> XObj + + public export + data XMorph : XObj -> XObj -> Type where + XMid : (a : XObj) -> XMorph a a + XMcomp : {a, b, c : XObj} -> XMorph b c -> XMorph a b + XM1 : (a : XObj) -> XMorph a XO1 + XMt : XMorph XO1 XOB + XMf : XMorph XO1 XOB + XMb : {a : XObj} -> XMorph XO1 a -> XMorph XO1 a -> XMorph XOB a + XOPp : (a, b, c : XObj) -> XMorph a b -> XMorph a c -> XMorph a (XOP b c) + XOPl : (a, b : XObj) -> XMorph (XOP a b) a + XOPr : (a, b : XObj) -> XMorph (XOP a b) b + XOEi1 : {a, b : XObj} -> (f, g : XMorph a b) -> XMorph (XOEq {a} {b} f g) a + XOEi2 : {a, b : XObj} -> (f, g : XMorph a b) -> XMorph (XOEq {a} {b} f g) b + XMchi : {a, b : XObj} -> XMorph a b -> XMorph a b -> XMorph a XOB + +-------------------------------------------------------- +-------------------------------------------------------- +---- Index type (used for positions and directions) ---- +-------------------------------------------------------- +-------------------------------------------------------- + +public export +data IdxObj : Type where + I0 : IdxObj + I1 : IdxObj + IC : IdxObj -> IdxObj -> IdxObj + IP : IdxObj -> IdxObj -> IdxObj + IH : IdxObj -> IdxObj -> IdxObj + IN : (n : Nat) -> {auto 0 ok : Not (n = 0)} -> IdxObj -- arithmetic modulo n + +mutual + public export + data IdxTerm : IdxObj -> Type where + TU : IdxTerm I1 + TL : IdxTerm a -> (b : IdxObj) -> IdxTerm (IC a b) + TR : (a : IdxObj) -> IdxTerm b -> IdxTerm (IC a b) + TP : IdxTerm a -> IdxTerm b -> IdxTerm (IP a b) + TQ : IdxMorph a b -> IdxTerm (IH a b) -- quote + TN : (m, n : Nat) -> + {auto 0 m_ok : Not (m = 0)} -> + {auto 0 n_ok : LT n m} -> + IdxTerm (IN {ok=m_ok} m) + + public export + data IdxMorph : IdxObj -> IdxObj -> Type where + MId : (a : IdxObj) -> IdxMorph a a + MComp : IdxMorph b c -> IdxMorph a b -> IdxMorph a c + M0 : (a : IdxObj) -> IdxMorph I0 a -- right adjunct (and counit in idx cat) + M1 : (a : IdxObj) -> IdxMorph a I1 -- left adjunct (and unit in idx cat) + MCil : (a, b : IdxObj) -> IdxMorph a (IC a b) -- from unit in product cat + MCir : (a, b : IdxObj) -> IdxMorph b (IC a b) -- from unit in product cat + MCe : IdxMorph a c -> IdxMorph b c -> IdxMorph (IC a b) c -- right adjunct + MPi : IdxMorph a b -> IdxMorph a c -> IdxMorph a (IP b c) -- left adjunct + MPel : (a, b : IdxObj) -> IdxMorph (IP a b) a -- from counit in product cat + MPer : (a, b : IdxObj) -> IdxMorph (IP a b) b -- from counit in product cat + MDist : (a, b, c : IdxObj) -> + IdxMorph (IP a (IC b c)) (IC (IP a b) (IP a c)) + MU : IdxTerm (IH a b) -> IdxMorph a b -- unquote + Mev : (a, b : IdxObj) -> IdxMorph (IP (IH a b) a) b -- counit + Mcu : IdxMorph (IP a b) c -> IdxMorph a (IH b c) -- left adjunct + + -- Polynomial modular arithemetic + Mninj : (m, n : Nat) -> + {auto 0 m_ok : Not (m = 0)} -> {auto 0 n_ok : Not (n = 0)} -> + IdxMorph (IN m) (IN n) + Mconst : (m, n : Nat) -> {auto 0 ok : Not (m = 0)} -> IdxMorph I1 (IN m) + Madd : {n : Nat} -> {auto 0 ok : Not (n = 0)} -> + IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) + Msub : {n : Nat} -> {auto 0 ok : Not (n = 0)} -> + IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) + Mmult : {n : Nat} -> {auto 0 ok : Not (n = 0)} -> + IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) + Mdiv : {n : Nat} -> {auto 0 ok : Not (n = 0)} -> + IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) + Mmod : {n : Nat} -> {auto 0 ok : Not (n = 0)} -> + IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) -> IdxMorph (IN n) (IN n) + Mlt : {m, n : Nat} -> + {auto 0 m_ok : Not (m = 0)} -> {auto 0 n_ok : Not (n = 0)} -> + IdxMorph (IN m) (IN m) -> IdxMorph (IN m) (IN m) -> + IdxMorph (IN m) (IC I1 I1) + +--------------------------------------------------------------------- +--------------------------------------------------------------------- +---- Simple S-expression type that can itself be used as an atom ---- +--------------------------------------------------------------------- +--------------------------------------------------------------------- + +---------------------- +---- Simple types ---- +---------------------- + +public export +OExp : Type +OExp = SExp BCDOPos + +public export +OExpBoolAlg : Type +OExpBoolAlg = SExpBoolAlg BCDOPos + +public export +checkAsBCDOAlg : OExpBoolAlg +checkAsBCDOAlg _ (_ :: _) = Nothing +checkAsBCDOAlg BCDO_0 [] = Just 0 +checkAsBCDOAlg BCDO_1 [] = Just 0 +checkAsBCDOAlg BCDO_C [] = Just 2 +checkAsBCDOAlg BCDO_P [] = Just 2 + +public export +checkAsBCDO : OExp -> Bool +checkAsBCDO = sexpBoolCata checkAsBCDOAlg + +public export +ORExp : Type +ORExp = SExpRefined checkAsBCDOAlg + +public export +OCExp : Type +OCExp = SExpConstrained checkAsBCDOAlg + +------------------------------ +---- Simple untyped terms ---- +------------------------------ + +public export +TExp : Type +TExp = SExp BCDTPos + +public export +TExpBoolAlg : Type +TExpBoolAlg = SExpBoolAlg BCDTPos + +public export +checkAsBCDTAlg : TExpBoolAlg +checkAsBCDTAlg _ (_ :: _) = Nothing +checkAsBCDTAlg BCDT_U [] = Just 0 +checkAsBCDTAlg BCDT_L [] = Just 1 +checkAsBCDTAlg BCDT_R [] = Just 1 +checkAsBCDTAlg BCDT_P [] = Just 2 + +public export +checkAsBCDT : TExp -> Bool +checkAsBCDT = sexpBoolCata checkAsBCDTAlg + +public export +TRExp : Type +TRExp = SExpRefined checkAsBCDTAlg + +public export +TCExp : Type +TCExp = SExpConstrained checkAsBCDTAlg + +---------------------------- +---- Simple typed terms ---- +---------------------------- + +----------------------------------------------------------- +----------------------------------------------------------- +---- Type-checking of S-expression as minimal Geb term ---- +----------------------------------------------------------- +----------------------------------------------------------- + +-- Check whether a term represents a type comprised of finite products +-- and coproducts (which are spanned by an initial object, a terminal +-- object, binary coproducts, and binary products). +public export +checkAsFinPCAlg : GExpBoolAlg +checkAsFinPCAlg FBT_INITIAL [] = Just 0 +checkAsFinPCAlg FBT_TERMINAL [] = Just 0 +checkAsFinPCAlg FBT_COPRODUCT [] = Just 2 +checkAsFinPCAlg FBT_PRODUCT [] = Just 2 +checkAsFinPCAlg _ _ = Nothing + +public export +checkAsFinPC : GExp -> Bool +checkAsFinPC = sexpBoolCata checkAsFinPCAlg + +public export +FinPCGExp : Type +FinPCGExp = Refinement {a=GExp} checkAsFinPC + +-- Check whether a term represents a term of a type comprised of finite products +-- and coproducts. +public export +checkAsFinTAlg : GExpBoolAlg +checkAsFinTAlg TERM_U [] = Just 0 +checkAsFinTAlg TERM_L [] = Just 1 +checkAsFinTAlg TERM_R [] = Just 1 +checkAsFinTAlg TERM_P [] = Just 2 +checkAsFinTAlg _ _ = Nothing + +public export +checkAsFinT : GExp -> Bool +checkAsFinT = sexpBoolCata checkAsFinTAlg + +public export +FinTGExp : Type +FinTGExp = Refinement {a=GExp} checkAsFinT + +-- Check whether a term represents a term of a _given_ type. +public export +checkAsFinTypedAlg : GExpMaybeCtxAlg FinTGExp Unit +checkAsFinTypedAlg = ?checkAsFinTypedAlg_hole + +-------------------------------------------- +-------------------------------------------- +---- Sigma types in programmer's FinSet ---- +-------------------------------------------- +-------------------------------------------- + +public export +data PFSTermF : Type -> Type where + -- Orders + PTO0 : PFSTermF a + PTO1 : PFSTermF a + PTO2 : PFSTermF a + + -- Classes + PTCterm : PFSTermF a + PTCtyped : PFSTermF a -- pair of type and term + + -- A typed term -- a pair of type and term + PTT : a -> a -> PFSTermF a + + -- Non-dependent-type-forming terms + PT0 : PFSTermF a -- Initial/Void + PT1 : PFSTermF a -- Terminal/Unit + PTC : a -> a -> PFSTermF a -- Coproduct/Either + PTP : a -> a -> PFSTermF a -- Product/Pair + + -- Term-forming terms + PTu : PFSTermF a -- !/() + PTl : a -> PFSTermF a -- inl/Left + PTr : a -> PFSTermF a -- inr/Right + PTp : a -> a -> PFSTermF a -- inp/MkPair + + -- Dependent-type-forming terms + + -- An nth-order predicate: meaning, an order-n type which depends upon on + -- order-n type. This predicate is itself a term of an order-(n+1) type. + -- + -- Another way of viewing this is as an order-(n+1) morphism + -- from some order-n type (as injected into order n+1) to the order-(n+1) + -- representation of the type of order-n types. The first parameter is the + -- order, and the second parameter is the order-n type (as injected into + -- order (n+1)) constituting the domain. + PTpr : a -> a -> PFSTermF a + + -- An nth-order sigma type; the parameter is an nth-order predicate. + -- (Note that the nth-order predicate may be viewed as a term of an + -- order-(n+1) type, or a morphism between order-(n+1) types.) + PTsig : a -> PFSTermF a + + -- An nth-order pi type; the parameter is an nth-order predicate. + PTpi : a -> PFSTermF a + +public export +data PFSTermFM : Type -> Type where + PTVar : a -> PFSTermFM a + PTCom : PFSTermF (PFSTermFM a) -> PFSTermFM a + +public export +PFSTAlg : Type -> Type +PFSTAlg a = PFSTermF a -> a + +public export +pfstFreeCata : {0 a, b : Type} -> (a -> b) -> PFSTAlg b -> PFSTermFM a -> b +pfstFreeCata subst alg (PTVar v) = subst v +pfstFreeCata subst alg (PTCom t) = alg $ case t of + PTO0 => PTO0 + PTO1 => PTO1 + PTO2 => PTO2 + PTCterm => PTCterm + PTCtyped => PTCtyped + PTT x y => PTT (pfstFreeCata subst alg x) (pfstFreeCata subst alg y) + PT0 => PT0 + PT1 => PT1 + PTC x y => PTC (pfstFreeCata subst alg x) (pfstFreeCata subst alg y) + PTP x y => PTP (pfstFreeCata subst alg x) (pfstFreeCata subst alg y) + PTu => PTu + PTl x => PTl (pfstFreeCata subst alg x) + PTr x => PTr (pfstFreeCata subst alg x) + PTp x y => PTp (pfstFreeCata subst alg x) (pfstFreeCata subst alg y) + PTpr x y => PTpr (pfstFreeCata subst alg x) (pfstFreeCata subst alg y) + PTsig x => PTsig (pfstFreeCata subst alg x) + PTpi x => PTpi (pfstFreeCata subst alg x) + +public export +PFSTShowAlg : PFSTAlg String +PFSTShowAlg PTO0 = "O(0)" +PFSTShowAlg PTO1 = "O(1)" +PFSTShowAlg PTO2 = "O(2)" +PFSTShowAlg PTCterm = "term" +PFSTShowAlg PTCtyped = "typed" +PFSTShowAlg (PTT type term) = "(" ++ term ++ ": " ++ type ++ ")" +PFSTShowAlg PT0 = "Void" +PFSTShowAlg PT1 = "Unit" +PFSTShowAlg (PTC x y) = "(" ++ x ++ " + " ++ y ++ ")" +PFSTShowAlg (PTP x y) = "(" ++ x ++ " * " ++ y ++ ")" +PFSTShowAlg PTu = "!" +PFSTShowAlg (PTl x) = "<(" ++ x ++ ")" +PFSTShowAlg (PTr x) = ">(" ++ x ++ ")" +PFSTShowAlg (PTp x y) = "(" ++ x ++ "," ++ y ++ ")" +PFSTShowAlg (PTpr x y) = "(" ++ x ++ ":" ++ y ++ ")" +PFSTShowAlg (PTsig x) = "Sig(" ++ x ++ ")" +PFSTShowAlg (PTpi x) = "Pi(" ++ x ++ ")" + +public export +pfstShow : {0 a : Type} -> (a -> String) -> PFSTermFM a -> String +pfstShow sh = pfstFreeCata sh PFSTShowAlg + +public export +Show a => Show (PFSTermFM a) where + show = pfstShow show + +public export +PFSTerm : Type +PFSTerm = PFSTermFM Void + +public export +pfstCata : {0 a : Type} -> PFSTAlg a -> PFSTerm -> a +pfstCata {a} = pfstFreeCata {a=Void} {b=a} (voidF a) + +public export +data PFSClass : Type where + PCTerm : PFSClass + PCType : PFSClass + PCTyped : PFSClass + +public export +data PFSDepClassType : Type where + PDCTTyped : PFSDepClassType + +public export +PFSDepClass : PFSClass -> Type +PFSDepClass PCTerm = Void +PFSDepClass PCType = PFSDepClassType +PFSDepClass PCTyped = Void + +public export +PFSDepMorph : Type -> Type -> Type +PFSDepMorph a b = PFSClass -> a -> b + +public export +PFSDepMorphCtx : Type -> Type -> Type -> Type +PFSDepMorphCtx ctx a b = Sigma {a=PFSClass} PFSDepClass -> a -> ctx -> b + +public export +PFSSlicePred : Type -> Type +PFSSlicePred a = + (PFSDepMorph a (Maybe (PFSTermFM a)), + PFSDepMorphCtx (PFSTermFM a) a (Maybe (PFSTermFM a))) + +mutual + public export + checkPFSTermSl : {0 a : Type} -> PFSSlicePred a -> + PFSClass -> DecPred (PFSTermFM a) + checkPFSTermSl pred c (PTVar v) = isJust $ fst pred c v + checkPFSTermSl pred PCTyped (PTCom t) = case t of + PTT type term => checkPFSTypedTerm pred type term + _ => False + checkPFSTermSl pred c t = ?checkPFSTermSl_hole + + public export + checkPFSTypedTerm : {0 a : Type} -> PFSSlicePred a -> + PFSTermFM a -> PFSTermFM a -> Bool + checkPFSTypedTerm {a} pred (PTVar ty) (PTVar v) = + isJust $ fst pred PCType ty >>= snd pred (PCType ** PDCTTyped) v + checkPFSTypedTerm {a} pred (PTVar ty) (PTCom term) = + let ty' = fst pred PCType ty in + ?checkPFSTypedTerm_hole_1 + checkPFSTypedTerm {a} pred (PTCom ty) (PTVar v) = ?checkPFSTypedTerm_hole_2 + checkPFSTypedTerm {a} pred (PTCom ty) (PTCom term) = ?checkPFSTypedTerm_hole_3 + +public export +checkPFSTerm : {0 a : Type} -> PFSSlicePred a -> DecPred (PFSTermFM a) +checkPFSTerm pred = checkPFSTermSl pred PCTyped + +------------------- +------------------- +---- Relations ---- +------------------- +------------------- + +public export +data CatMorphPos : Type where + CSId : CatMorphPos + CSComp : CatMorphPos + +public export +data CatMorphDir : CatMorphPos -> Type where + CSObj : CatMorphDir CSId + CSLeft : CatMorphDir CSComp + CSRight : CatMorphDir CSComp + +public export +CatMorphF : PolyFunc +CatMorphF = (CatMorphPos ** CatMorphDir) + +public export +data CatMorphDom : Type where + CSDObj : CatMorphDom + CSDMorph : CatMorphDom + +public export +CatMorphAssign : Sigma CatMorphDir -> CatMorphDom +CatMorphAssign (CSId ** CSObj) = CSDObj +CatMorphAssign (CSComp ** d) = CSDMorph + +public export +CatMorphSPF : SlicePolyFunc CatMorphDom Unit +CatMorphSPF = pfSlice CatMorphF CatMorphAssign + +public export +data SymRelPos : Type where + SRPSym : SymRelPos + +public export +data SymRelDir : SymRelPos -> Type where + SRDSym : SymRelDir SRPSym + +public export +SymRelAssign : Sigma SymRelDir -> CatMorphDom +SymRelAssign (SRPSym ** SRDSym) = CSDMorph + +public export +SymRelSPF : SlicePolyFunc CatMorphDom Unit +SymRelSPF = + (const SymRelPos ** + SymRelDir . snd ** + \((() ** i) ** d) => SymRelAssign (i ** d)) + +public export +EqRelSPF : SlicePolyFunc CatMorphDom Unit +EqRelSPF = SPFSliceCoproduct CatMorphSPF SymRelSPF + +public export +EqRelPos : Type +EqRelPos = spfPos EqRelSPF () + +public export +EqRelDir : EqRelPos -> Type +EqRelDir i = spfDir EqRelSPF (() ** i) + +public export +data DeqRelPosExt : Type where + DRPDec : DeqRelPosExt + +public export +data DeqRelDirExt : DeqRelPosExt -> Type where + DRDLeft : DeqRelDirExt DRPDec + DRDRight : DeqRelDirExt DRPDec + +public export +DeqRelAssignExt : Sigma DeqRelDirExt -> CatMorphDom +DeqRelAssignExt (DRPDec ** d) = CSDObj + +public export +DeqRelExtF : SlicePolyFunc CatMorphDom Unit +DeqRelExtF = + (const DeqRelPosExt ** + DeqRelDirExt . snd ** + \((() ** i) ** d) => DeqRelAssignExt (i ** d)) + +------------------------------------------------------ +------------------------------------------------------ +---- Dependent polynomial endofunctors as W-types ---- +------------------------------------------------------ +------------------------------------------------------ + +-------------------------------------------------- +---- Definition and interpretation of W-types ---- +-------------------------------------------------- + +public export +record WTypeFunc (parambase, posbase : Type) where + constructor MkWTF + wtPos : Type + wtDir : Type + wtAssign : wtDir -> parambase + wtDirSlice : wtDir -> wtPos + wtPosSlice : wtPos -> posbase + +public export +WTypeEndoFunc : Type -> Type +WTypeEndoFunc base = WTypeFunc base base + +public export +InterpWTF : {parambase, posbase : Type} -> + WTypeFunc parambase posbase -> SliceFunctor parambase posbase +InterpWTF {parambase} {posbase} wtf sl ib = + (i : PreImage {a=(wtPos wtf)} {b=posbase} (wtPosSlice wtf) ib ** + (d : PreImage {a=(wtDir wtf)} {b=(wtPos wtf)} (wtDirSlice wtf) (fst0 i)) -> + sl $ wtAssign wtf $ fst0 d) + +public export +WTFtoSPF : {parambase, posbase : Type} -> + WTypeFunc parambase posbase -> SlicePolyFunc parambase posbase +WTFtoSPF {parambase} {posbase} (MkWTF pos dir assign dsl psl) = + (\i => PreImage {a=pos} {b=posbase} psl i ** + \x => PreImage {a=dir} {b=pos} dsl $ fst0 $ snd x ** + \d => assign $ fst0 $ snd d) + +public export +SPFtoWTF : {parambase, posbase : Type} -> + SlicePolyFunc parambase posbase -> WTypeFunc parambase posbase +SPFtoWTF (posdep ** dirdep ** assign) = + MkWTF + (Sigma {a=posbase} posdep) + (Sigma {a=(Sigma {a=posbase} posdep)} dirdep) + assign + fst + fst + +public export +InterpWTFtoSPF : {parambase, posbase : Type} -> + (wtf : WTypeFunc parambase posbase) -> + (sl : SliceObj parambase) -> (ib : posbase) -> + InterpSPFunc {a=parambase} {b=posbase} + (WTFtoSPF {parambase} {posbase} wtf) sl ib -> + InterpWTF {parambase} {posbase} wtf sl ib +InterpWTFtoSPF (MkWTF pos dir assign dsl psl) sl ib = id + +public export +InterpWTFtoSPFInv : {parambase, posbase : Type} -> + (wtf : WTypeFunc parambase posbase) -> + (sl : SliceObj parambase) -> (ib : posbase) -> + InterpWTF {parambase} {posbase} wtf sl ib -> + InterpSPFunc {a=parambase} {b=posbase} + (WTFtoSPF {parambase} {posbase} wtf) sl ib +InterpWTFtoSPFInv (MkWTF pos dir assign dsl psl) sl ib = id + +public export +InterpSPFtoWTF : {parambase, posbase : Type} -> + (spf : SlicePolyFunc parambase posbase) -> + (sl : SliceObj parambase) -> (ib : posbase) -> + InterpWTF {parambase} {posbase} (SPFtoWTF {parambase} {posbase} spf) sl ib -> + InterpSPFunc {a=parambase} {b=posbase} spf sl ib +InterpSPFtoWTF {parambase} {posbase} (posdep ** dirdep ** assign) sl ib + (Element0 {type=(Sigma {a=posbase} posdep)} (ib' ** i) eq ** p) = + (rewrite sym eq in i ** + \d => p $ + Element0 ((ib ** rewrite sym eq in i) ** d) (rewrite sym eq in Refl)) + +public export +InterpSPFtoWTFInv : {parambase, posbase : Type} -> + (spf : SlicePolyFunc parambase posbase) -> + (sl : SliceObj parambase) -> (ib : posbase) -> + InterpSPFunc {a=parambase} {b=posbase} spf sl ib -> + InterpWTF {parambase} {posbase} (SPFtoWTF {parambase} {posbase} spf) sl ib +InterpSPFtoWTFInv {parambase} {posbase} (posdep ** dirdep ** assign) sl ib + (i ** d) = + (Element0 (ib ** i) Refl ** + \(Element0 (i' ** di) deq) => rewrite deq in d $ rewrite sym deq in di) + +----------------------------- +---- Algebras of W-types ---- +----------------------------- + +public export +WTFAlg : {a : Type} -> WTypeEndoFunc a -> SliceObj a -> Type +WTFAlg {a} wtf sa = SliceMorphism {a} (InterpWTF wtf sa) sa + +------------------------------------- +---- Initial algebras of W-types ---- +------------------------------------- + +public export +data WTFMu : {a : Type} -> WTypeEndoFunc a -> SliceObj a where + InWTFM : {a : Type} -> {wtf : WTypeEndoFunc a} -> + (i : (dc : a ** PreImage {a=(wtPos wtf)} {b=a} (wtPosSlice wtf) dc)) -> + ((d : + PreImage {a=(wtDir wtf)} {b=(wtPos wtf)} + (wtDirSlice wtf) (fst0 (snd i))) -> + WTFMu {a} wtf (wtAssign wtf (fst0 d))) -> + WTFMu {a} wtf (fst i) + +public export +wtfCata : {0 a : Type} -> {wtf : WTypeEndoFunc a} -> {sa : SliceObj a} -> + WTFAlg wtf sa -> SliceMorphism {a} (WTFMu wtf) sa +wtfCata {a} {wtf} {sa} alg _ (InWTFM (dc ** i) dm) = + alg dc (i ** \d => wtfCata {a} {wtf} {sa} alg (wtAssign wtf (fst0 d)) $ dm d) + +------------------------------------------------------------------ +------------------------------------------------------------------ +---- "Interpretation" of morphisms as natural transformations ---- +------------------------------------------------------------------ +------------------------------------------------------------------ + +public export +record DiagSig (obj, morph : Type) where + constructor DSig + dsigDom : morph -> obj + dsigCod : morph -> obj + +-- Data which determine a polynomial functor which takes (dependent) diagrams +-- to (dependent) objects. +public export +record DPDiagramObjF (0 paramdom, paramcod : Type) where + constructor DPDF + dpdfObjPos : paramcod -> Type + dpdfObjDirObj : Sigma {a=paramcod} dpdfObjPos -> Type + dpdfObjDirMorph : Sigma {a=paramcod} dpdfObjPos -> Type + 0 dpdfObjConstraint : + (dp : paramdom) -> (dc : paramcod) -> (i : dpdfObjPos dc) -> + (obj : Type) -> + (dpdfObjDirObj (dc ** i) -> obj) -> + (dom : dpdfObjDirMorph (dc ** i) -> obj) -> + (cod : dpdfObjDirMorph (dc ** i) -> obj) -> + Type + +-- Interpret the data of a `DPDiagramObjF` to produce a dependent polynomial +-- functor which, given types of (dependent) objects and (dependent) morphisms, +-- returns a type of (dependent) objects. +public export +record InterpDPDF {0 paramdom, paramcod : Type} + (0 dpdf : DPDiagramObjF paramdom paramcod) + (0 obj : paramdom -> Type) (0 morph : paramdom -> Type) + (0 dom : (dp : paramdom) -> morph dp -> obj dp) + (0 cod : (dp : paramdom) -> morph dp -> obj dp) + (0 dc : paramcod) where + constructor IDPDF + idpdfParam : paramdom + idpdfPos : dpdf.dpdfObjPos dc + idpdfObj : dpdf.dpdfObjDirObj (dc ** idpdfPos) -> obj idpdfParam + idpdfMorph : dpdf.dpdfObjDirMorph (dc ** idpdfPos) -> morph idpdfParam + 0 idpdfObjConstraint : + dpdf.dpdfObjConstraint + idpdfParam + dc + idpdfPos + (obj idpdfParam) + idpdfObj + (dom idpdfParam . idpdfMorph) + (cod idpdfParam . idpdfMorph) + +----------------------------------------------------------------- +----------------------------------------------------------------- +---- Dependent polynomial functors generating compound types ---- +----------------------------------------------------------------- +----------------------------------------------------------------- + +--------------- +---- Maybe ---- +--------------- + +public export +MaybeSPF : Type -> Type +MaybeSPF = Maybe + +-------------- +---- Pair ---- +-------------- + +public export +PairSPF : (Type, Type) -> Type +PairSPF = uncurry Pair + +-------------- +---- Diag ---- +-------------- + +public export +DiagF : Type -> Type +DiagF a = PairSPF (a, a) + +---------------- +---- Either ---- +---------------- + +public export +EitherSPF: (Type, Type) -> Type +EitherSPF = uncurry Either + +--------------- +---- Split ---- +--------------- + +public export +SplitF : Type -> Type +SplitF a = EitherSPF (a, a) + +-------------- +---- List ---- +-------------- + +public export +ListSPF : (Type, Type) -> Type +ListSPF = MaybeSPF . PairSPF + +------------- +---- Nat ---- +------------- + +public export +NatSPF : Type -> Type +NatSPF = MaybeSPF + +--------------- +---- Const ---- +--------------- + +public export +ConstSPF : Type -> Type -> Type +ConstSPF = const + +-------------------------------- +---- Fin as refinement type ---- +-------------------------------- + +public export +FinR : Nat -> Type +FinR n = Subset0 Nat (flip LT n) + +--------------------------------- +---- Fin as constant functor ---- +--------------------------------- + +public export +FinRF : Nat -> Type -> Type +FinRF = ConstSPF . FinR + +------------------------------------- +---- GebAtom as constant functor ---- +------------------------------------- + +public export +GebAtomF : Type -> Type +GebAtomF = const GebAtom + +---------------------------------------- +---------------------------------------- +---- Finite product/coproduct types ---- +---------------------------------------- +---------------------------------------- + +-- The following functors operate on the product category `Type x Type x Type`; +-- they assume that the first type in the product is a type of types, the +-- second type is a type of pairs of types, and the third type is a type of +-- lists of types. + +-- A type is either an atom (reserved opcode), `FinR`, or a product or a +-- coproduct of either a pair or a list of types. +-- (The coproduct of an empty list of types is an initial +-- object; the product of an empty list of types is a +-- terminal object.) +public export +FinBCTF : (Type, Type, Type) -> Type +FinBCTF (a, b, c) = MaybeSPF (EitherSPF (Nat, SplitF (EitherSPF (b, c)))) + +-- The first type in the product is the type of types, so `DiagF` of that +-- first type is the type of pairs of types. +public export +FinBCTPF : (Type, Type, Type) -> Type +FinBCTPF (a, b, c) = DiagF a + +-- The type of lists of types is the type of either nothing or pairs of +-- types and lists of types. +public export +FinBCTLF : (Type, Type, Type) -> Type +FinBCTLF (a, b, c) = ListSPF (a, c) + +-- Here we put together the three `Type x Type x Type -> Type` functors into +-- a single `Type x Type x Type -> Type x Type x Type` endofunctor. + +public export +FinBCSlF : (Type, Type, Type) -> (Type, Type, Type) +FinBCSlF (a, b, c) = (FinBCTF (a, b, c), FinBCTPF (a, b, c), FinBCTLF (a, b, c)) + +public export +FinBCSPF : (FS3CP -> Type) -> FS3CP -> Type +FinBCSPF f (Left ()) = FinBCTF (f FS3CP0, f FS3CP1, f FS3CP2) +FinBCSPF f (Right (Left ())) = FinBCTPF (f FS3CP0, f FS3CP1, f FS3CP2) +FinBCSPF f (Right (Right ())) = FinBCTLF (f FS3CP0, f FS3CP1, f FS3CP2) + +public export +data FinBCSl : FS3CP -> Type where + -- This is the equivalent of the following: + -- InFBC : (sl : FS3CP) -> FinBCSPF FinBCSl sl -> FinBCSl sl + -- But Idris doesn't realize that that's total. + -- InFBC : (sl : FS3CP) -> FinBCSPF FinBCSl sl -> FinBCSl sl + InFBT : + FinBCTF (FinBCSl FS3CP0, FinBCSl FS3CP1, FinBCSl FS3CP2) -> FinBCSl FS3CP0 + InFBTP : + FinBCTPF (FinBCSl FS3CP0, FinBCSl FS3CP1, FinBCSl FS3CP2) -> FinBCSl FS3CP1 + InFBTL : + FinBCTLF (FinBCSl FS3CP0, FinBCSl FS3CP1, FinBCSl FS3CP2) -> FinBCSl FS3CP2 + +-- Finite product/coproduct types. +public export +FinBCT : Type +FinBCT = FinBCSl FS3CP0 + +-- Pairs of product/coproduct types. +public export +FinBCTP : Type +FinBCTP = FinBCSl FS3CP1 + +-- Lists of product/coproduct types. +public export +FinBCTL : Type +FinBCTL = FinBCSl FS3CP2 + +-- Make a term of type "pair of types" from a metalanguage pair of types. +public export +FTp : FinBCT -> FinBCT -> FinBCTP +FTp = InFBTP .* MkPair + +-- Make an atom type. +public export +FTA : FinBCT +FTA = InFBT Nothing + +-- Make a `FinR` type. +public export +FTN : Nat -> FinBCT +FTN = InFBT . Just . Left + +-- Form a coproduct type from a pair of types. +public export +FTCP : FinBCTP -> FinBCT +FTCP = InFBT . Just . Right . Left . Left + +-- Form a coproduct type from a list of types. +public export +FTCL : FinBCTL -> FinBCT +FTCL = InFBT . Just . Right . Left . Right + +-- Form a product type from a pair of types. +public export +FTPP : FinBCTP -> FinBCT +FTPP = InFBT . Just . Right . Right . Left + +-- Form a product type from a list of types. +public export +FTPL : FinBCTL -> FinBCT +FTPL = InFBT . Just . Right . Right . Right + +-- An empty list of types. +public export +FTn : FinBCTL +FTn = InFBTL Nothing + +-- Cons a type and a list of types to form another list of types. +public export +FTc : FinBCT -> FinBCTL -> FinBCTL +FTc = InFBTL . Just .* MkPair + +-- Cons a type and a list of types, then take the product of the +-- resulting list of types. +public export +FTcp : FinBCT -> FinBCTL -> FinBCT +FTcp = FTPL .* FTc + +-- Cons a type and a list of types, then take the coproduct of the +-- resulting list of types. +public export +FTcc : FinBCT -> FinBCTL -> FinBCT +FTcc = FTCL .* FTc + +-- Make a term of type "list of types" from a metalanguage list of types. +public export +FTl : List FinBCT -> FinBCTL +FTl = foldr FTc FTn + +------------------------------------------ +------------------------------------------ +---- S-expressions representing types ---- +------------------------------------------ +------------------------------------------ + +public export +FTypeAlg : (FS3CP -> Type) -> Type +FTypeAlg sa = SliceMorphism {a=FS3CP} (FinBCSPF sa) sa + +public export +ftypeCata : FTypeAlg sa -> SliceMorphism FinBCSl sa +ftypeCata alg (Left ()) (InFBT Nothing) = alg FS3CP0 Nothing +ftypeCata alg (Left ()) (InFBT (Just (Left k))) = alg FS3CP0 $ Just $ Left k +ftypeCata alg (Left ()) (InFBT (Just (Right (Left (Left typ))))) = + alg FS3CP0 $ Just $ Right $ Left $ Left $ ftypeCata alg FS3CP1 typ +ftypeCata alg (Left ()) (InFBT (Just (Right (Left (Right tyl))))) = + alg FS3CP0 $ Just $ Right $ Left $ Right $ ftypeCata alg FS3CP2 tyl +ftypeCata alg (Left ()) (InFBT (Just (Right (Right (Left typ))))) = + alg FS3CP0 $ Just $ Right $ Right $ Left $ ftypeCata alg FS3CP1 typ +ftypeCata alg (Left ()) (InFBT (Just (Right (Right (Right tyl))))) = + alg FS3CP0 $ Just $ Right $ Right $ Right $ ftypeCata alg FS3CP2 tyl +ftypeCata alg (Right (Left ())) (InFBTP (ty, ty')) = + alg FS3CP1 (ftypeCata alg FS3CP0 ty, ftypeCata alg FS3CP0 ty') +ftypeCata alg (Right (Right ())) (InFBTL Nothing) = + alg FS3CP2 Nothing +ftypeCata alg (Right (Right ())) (InFBTL (Just (ty, tys))) = + alg FS3CP2 $ Just (ftypeCata alg FS3CP0 ty, ftypeCata alg FS3CP2 tys) + +public export +FTypeToGExpSl : FS3CP -> Type +FTypeToGExpSl (Left ()) = GExp +FTypeToGExpSl (Right (Left ())) = (GExp, GExp) +FTypeToGExpSl (Right (Right ())) = List GExp + +public export +FTypeToGExpAlg : FTypeAlg FTypeToGExpSl +FTypeToGExpAlg (Left ()) Nothing = InSA FBT_ATOM +FTypeToGExpAlg (Left ()) (Just (Left k)) = InS FBT_BNAT [k] [] +FTypeToGExpAlg (Left ()) (Just (Right (Left (Left (MkPair x y))))) = InS FBT_COPRODUCT [] [x, y] +FTypeToGExpAlg (Left ()) (Just (Right (Left (Right l)))) = InS FBT_COPRODUCT_L [] l +FTypeToGExpAlg (Left ()) (Just (Right (Right (Left (MkPair x y))))) = InS FBT_PRODUCT [] [x, y] +FTypeToGExpAlg (Left ()) (Just (Right (Right (Right l)))) = InS FBT_PRODUCT_L [] l +FTypeToGExpAlg (Right (Left ())) (x, y) = (x, y) +FTypeToGExpAlg (Right (Right ())) Nothing = [] +FTypeToGExpAlg (Right (Right ())) (Just (x, xs)) = x :: xs + +public export +ftypeToGExp : SliceMorphism {a=FS3CP} FinBCSl FTypeToGExpSl +ftypeToGExp = ftypeCata FTypeToGExpAlg + +public export +BNatFromSExpAlg : GebAtom -> Pi {a=Nat} (GExpMaybeAlg . FinR) +BNatFromSExpAlg ea n (SXF a ns xs) = case decEq ea a of + Yes Refl => case (ns, xs) of + ([n'], []) => case isLT n' n of + Yes nlt => Just $ Element0 n' nlt + No _ => Nothing + _ => Nothing + No _ => Nothing + +public export +bnatFromSExp : SliceMorphism {a=Nat} (const GExp) (Maybe . FinR) +bnatFromSExp n = sexpMaybeCata $ BNatFromSExpAlg FBT_BNAT n + +public export +fs3FromFinR3 : FinR 3 -> FS3CP +fs3FromFinR3 (Element0 0 lt3) = FS3CP0 +fs3FromFinR3 (Element0 1 lt3) = FS3CP1 +fs3FromFinR3 (Element0 2 lt3) = FS3CP2 +fs3FromFinR3 (Element0 (S (S (S k))) lt3) = void $ case lt3 of + LTEZero impossible + LTESucc lt2 => case lt2 of + LTEZero impossible + LTESucc lt1 => case lt1 of + LTEZero impossible + LTESucc lt0 => case lt0 of + LTEZero impossible + LTESucc _ impossible + +public export +ftSliceFromGExp : GExp -> Maybe FS3CP +ftSliceFromGExp = map fs3FromFinR3 . bnatFromSExp 3 + +------------------------------------------------- +------------------------------------------------- +---- Terms of finite product/coproduct types ---- +------------------------------------------------- +------------------------------------------------- + +public export +ProdTermF : (a -> Type, b -> Type) -> PairSPF (a, b) -> Type +ProdTermF f x = ((fst f) (fst x), (snd f) (snd x)) + +public export +CoprodTermF : (a -> Type, b -> Type) -> EitherSPF (a, b) -> Type +CoprodTermF f x = case x of Left ea => fst f ea ; Right eb => snd f eb + +public export +ListTermF : (a -> Type, b -> Type) -> ListSPF (a, b) -> Type +ListTermF f x = case x of Nothing => Unit ; Just p => ProdTermF f p -- nil/cons + +public export +data FTSlice : Type where + -- A term of the given type + FTTerm : FinBCT -> FTSlice + -- A pair of terms, one of each of the two given types + FTProdP : FinBCTP -> FTSlice + -- A term from one or the other of the two given types + FTCopP : FinBCTP -> FTSlice + -- A list of terms, one of each of the given types + FTProdL : FinBCTL -> FTSlice + -- A term from one of the given types + FTCopL : FinBCTL -> FTSlice + +-- The slice representing terms of an atom type +public export +FTSlA : FTSlice +FTSlA = FTTerm FTA + +-- The slice representing terms of a bounded-natural-number type +public export +FTSlN : Nat -> FTSlice +FTSlN = FTTerm . FTN + +-- The slice representing terms of a coproduct of a pair of types +public export +FTSlCP : FinBCTP -> FTSlice +FTSlCP = FTTerm . FTCP + +-- The slice representing terms of a coproduct of a list of types +public export +FTSlCL : FinBCTL -> FTSlice +FTSlCL = FTTerm . FTCL + +-- The slice representing terms of a product of a pair of types +public export +FTSlPP : FinBCTP -> FTSlice +FTSlPP = FTTerm . FTPP + +-- The slice representing terms of a product of a list of types +public export +FTSlPL : FinBCTL -> FTSlice +FTSlPL = FTTerm . FTPL + +-- The slice representing terms of either of a pair of types +public export +FTSlCopP : FinBCT -> FinBCT -> FTSlice +FTSlCopP = FTCopP .* FTp + +-- The slice representing terms of either a type or a list of types +public export +FTSlCopL : FinBCT -> FinBCTL -> FTSlice +FTSlCopL = FTCopL .* FTc + +-- The slice representing terms of unit type +public export +FTSlUnit : FTSlice +FTSlUnit = FTProdL FTn + +-- The slice representing terms of each of a pair of types +public export +FTSlProdP : FinBCT -> FinBCT -> FTSlice +FTSlProdP = FTProdP .* FTp + +-- The slice representing terms of a type together with terms of +-- each of a list of types +public export +FTSlProdL : FinBCT -> FinBCTL -> FTSlice +FTSlProdL = FTProdL .* FTc + +public export +data FinTermSl : FTSlice -> Type where + -- A term of an atom type is an atom + InFTA : GebAtom -> FinTermSl FTSlA + -- A term of a bounded-natural-number type is a number which obeys the bounds. + InFTN : {0 n : Nat} -> FinR n -> FinTermSl $ FTSlN n + -- A term of a coproduct type is a term from one of the component types. + InFTCP : {0 typ : FinBCTP} -> + FinTermSl (FTCopP typ) -> FinTermSl $ FTSlCP typ + InFTCL : {0 tys : FinBCTL} -> + FinTermSl (FTCopL tys) -> FinTermSl $ FTSlCL tys + -- A term of a product type is a term from each of the component types. + InFTPP : {0 tys : FinBCTP} -> + FinTermSl (FTProdP tys) -> FinTermSl $ FTSlPP tys + InFTPL : {0 tys : FinBCTL} -> + FinTermSl (FTProdL tys) -> FinTermSl $ FTSlPL tys + -- There are no terms whose type is the coproduct of an empty list + -- (that type is `Void`, the initial object). A term of a coproduct + -- of a non-empty list is either a term of the head type or a term + -- from one of the tail types. + InFTL : {0 tyl, tyr : FinBCT} -> + FinTermSl (FTTerm tyl) -> FinTermSl $ FTSlCopP tyl tyr + InFTR : {0 tyl, tyr : FinBCT} -> + FinTermSl (FTTerm tyr) -> FinTermSl $ FTSlCopP tyl tyr + InFTH : {0 ty : FinBCT} -> {0 tys : FinBCTL} -> + FinTermSl (FTTerm ty) -> FinTermSl $ FTSlCopL ty tys + InFTTL : {0 ty : FinBCT} -> {0 tys : FinBCTL} -> + FinTermSl (FTCopL tys) -> FinTermSl $ FTSlCopL ty tys + -- A term of the product of an empty list is unit. + InFTU : FinTermSl $ FTSlUnit + -- A term of a type of pairs of types is a term of the first type + -- together with a term of the second type. + InFPair : {0 tyl, tyr : FinBCT} -> + FinTermSl (FTTerm tyl) -> FinTermSl (FTTerm tyr) -> + FinTermSl $ FTSlProdP tyl tyr + -- A term of the product of a non-empty list is a term of the head type + -- together with a list of terms from each of the tail types. + InFList : {0 ty : FinBCT} -> {0 tys : FinBCTL} -> + FinTermSl (FTTerm ty) -> FinTermSl (FTProdL tys) -> + FinTermSl $ FTSlProdL ty tys + +public export +FinTermA : Type +FinTermA = FinTermSl FTSlA + +public export +FinTermN : Nat -> Type +FinTermN = FinTermSl . FTSlN + +public export +TA : GebAtom -> FinTermA +TA = InFTA + +-------------------------------------------- +-------------------------------------------- +---- Vectors of bounded natural numbers ---- +-------------------------------------------- +-------------------------------------------- + public export FinV : {0 len : Nat} -> SliceObj (Vect len Nat) FinV [] = () @@ -368,6 +2791,83 @@ data SAInterpMu : {0 base : Type} -> SliceEndoArena base -> SliceObj base where ------------------------------------------------------------------ ------------------------------------------------------------------ +-- Subobject classifier in what I think is the style of the HoTT book with +-- an `isProp` as in https://ncatlab.org/nlab/show/mere+proposition. + +public export +IsHProp : Type -> Type +IsHProp a = (x, y : a) -> x = y + +public export +SubCFromHProp : Type +SubCFromHProp = Subset0 Type IsHProp + +public export +PowerObjFromProp : Type -> Type +PowerObjFromProp a = a -> SubCFromHProp + +public export +TrueForHProp : () -> SubCFromHProp +TrueForHProp () = Element0 Unit $ \(), () => Refl + +public export +ChiForHProp : {0 a, b : Type} -> + (f : a -> b) -> ((x, y : a) -> f x = f y -> x = y) -> + b -> SubCFromHProp +ChiForHProp {a} {b} f isMonic eb = + Element0 + (Exists0 a $ \x => f x = eb) + $ \(Evidence0 x eqx), (Evidence0 y eqy) => + case isMonic x y (trans eqx (sym eqy)) of + Refl => case uip {eq=eqx} {eq'=eqy} of + Refl => Refl + +public export +0 ChiForHPropPbToDom : {0 a, b : Type} -> + (f : a -> b) -> (isMonic : (x, y : a) -> f x = f y -> x = y) -> + Pullback {a=b} {b=Unit} {c=SubCFromHProp} + (ChiForHProp f isMonic) TrueForHProp -> + a +ChiForHPropPbToDom {a} {b} f isMonic (Element0 (eb, ()) eq) = + fst0 $ replace {p=id} (sym $ elementInjectiveFst eq) () + +-- `Type` itself as a subobject classifier -- treating it like `Prop`. +public export +SubCFromTypeAsSubC : Type +SubCFromTypeAsSubC = Type + +public export +PowerObjFromTypeAsSubC : Type -> Type +PowerObjFromTypeAsSubC = SliceObj + +public export +CharToPowerFromTypeAsSubC : {0 a : Type} -> + (a -> SubCFromTypeAsSubC) -> PowerObjFromTypeAsSubC a +CharToPowerFromTypeAsSubC {a} chi = chi + +public export +PowerToCharFromTypeAsSubC : {0 a : Type} -> + PowerObjFromTypeAsSubC a -> (a -> SubCFromTypeAsSubC) +PowerToCharFromTypeAsSubC {a} po e = po e + +public export +TrueFromTypeAsSubC : () -> SubCFromTypeAsSubC +TrueFromTypeAsSubC () = () + +public export +ChiForTypeAsSubC : {0 a, b : Type} -> (a -> b) -> b -> SubCFromTypeAsSubC +ChiForTypeAsSubC {a} {b} m eb = Exists0 a $ \ea => m ea = eb + +public export +ChiForTypeAsSubCToPb : + (subCmereProp : {p, p' : SubCFromTypeAsSubC} -> p = p') -> + {0 a, b : Type} -> (f, g : a -> b) -> + (ee : Equalizer f g) -> + Pullback {a} {b=Unit} {c=SubCFromTypeAsSubC} + (ChiForTypeAsSubC (equalizerInj f g)) TrueFromTypeAsSubC +ChiForTypeAsSubCToPb subCmereProp {a} {b} f g (Element0 eeq eq) = + Element0 (eeq, ()) subCmereProp + -- A type together with a term of that type. public export SubCFromType : Type @@ -626,6 +3126,8 @@ record TFunctorSig (c, d : TCatSig) where {dom'=(tfObjMap a')} {cod'=(tfObjMap b')} domMapEq codMapEq (tfMorphMap {a} {b} m) (tfMorphMap {a=a'} {b=b'} m') + -- The laws for the application of functors to identities and + -- compositions must still be written. ------------------------- ------------------------- @@ -905,13 +3407,9 @@ public export GWExpWTF : WTypeEndoFunc GExpSlice GWExpWTF = MkWTF GWExpPos GWExpDir gAssign gDirSlice gPosSlice -public export -GWExpSPF : SlicePolyEndoFunc GExpSlice -GWExpSPF = WTFtoSPF GWExpWTF - public export GWExpWT : SliceObj GExpSlice -GWExpWT = SPFMu GWExpSPF +GWExpWT = WTFMu GWExpWTF public export GWExpSigma : Type @@ -950,7 +3448,7 @@ record GWExpAlg (sa : GExpSlice -> Type) where galgXC : sa GSEXP -> sa GSEXPL -> sa GSEXPL public export -GAlgToSPF : {sa : GExpSlice -> Type} -> GWExpAlg sa -> SPFAlg GWExpSPF sa +GAlgToSPF : {sa : GExpSlice -> Type} -> GWExpAlg sa -> WTFAlg GWExpWTF sa GAlgToSPF alg GSATOM (Element0 (GPA a) isl ** d) = alg.galgA a GAlgToSPF alg GSATOM (Element0 (GPNAP GPNAZ) isl ** d) = @@ -1036,7 +3534,7 @@ GAlgToSPF alg GSEXPL (Element0 (GPNAP GPNAXC) isl ** d) = public export gwexpCata : {sa : GExpSlice -> Type} -> GWExpAlg sa -> SliceMorphism {a=GExpSlice} GWExpWT sa -gwexpCata {sa} alg = spfCata {spf=GWExpSPF} {sa} (GAlgToSPF {sa} alg) +gwexpCata {sa} alg = wtfCata {wtf=GWExpWTF} {sa} (GAlgToSPF {sa} alg) public export GWExpWTtoGExpAlgSl : SliceObj GExpSlice @@ -1060,7 +3558,7 @@ gwexpWTtoGExp = gwexpWTtoGExpSl GSEXP public export InGA : GebAtom -> GWExpA -InGA a = InSPFM (GSATOM ** Element0 (GPA a) Refl) $ \(Element0 d dsl) => +InGA a = InWTFM (GSATOM ** Element0 (GPA a) Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1073,7 +3571,7 @@ InGA a = InSPFM (GSATOM ** Element0 (GPA a) Refl) $ \(Element0 d dsl) => public export InGZ : GWExpN -InGZ = InSPFM (GSNAT ** Element0 GPZ Refl) $ \(Element0 d dsl) => +InGZ = InWTFM (GSNAT ** Element0 GPZ Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1086,7 +3584,7 @@ InGZ = InSPFM (GSNAT ** Element0 GPZ Refl) $ \(Element0 d dsl) => public export InGS : GWExpN -> GWExpN -InGS n = InSPFM (GSNAT ** Element0 GPS Refl) $ \(Element0 d dsl) => +InGS n = InWTFM (GSNAT ** Element0 GPS Refl) $ \(Element0 d dsl) => case d of GDS => n GDXA => void $ case dsl of Refl impossible @@ -1104,7 +3602,7 @@ InGNat (S n) = InGS (InGNat n) public export InGNN : GWExpNL -InGNN = InSPFM (GSNATL ** Element0 GPNN Refl) $ \(Element0 d dsl) => +InGNN = InWTFM (GSNATL ** Element0 GPNN Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1117,7 +3615,7 @@ InGNN = InSPFM (GSNATL ** Element0 GPNN Refl) $ \(Element0 d dsl) => public export InGNC : GWExpN -> GWExpNL -> GWExpNL -InGNC n ns = InSPFM (GSNATL ** Element0 GPNC Refl) $ \(Element0 d dsl) => +InGNC n ns = InWTFM (GSNATL ** Element0 GPNC Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1138,7 +3636,7 @@ InGNatList = foldr InGNatC InGNN public export InGXN : GWExpXL -InGXN = InSPFM (GSEXPL ** Element0 GPXN Refl) $ \(Element0 d dsl) => +InGXN = InWTFM (GSEXPL ** Element0 GPXN Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1151,7 +3649,7 @@ InGXN = InSPFM (GSEXPL ** Element0 GPXN Refl) $ \(Element0 d dsl) => public export InGXC : GWExpX -> GWExpXL -> GWExpXL -InGXC x xs = InSPFM (GSEXPL ** Element0 GPXC Refl) $ \(Element0 d dsl) => +InGXC x xs = InWTFM (GSEXPL ** Element0 GPXC Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => void $ case dsl of Refl impossible @@ -1164,7 +3662,7 @@ InGXC x xs = InSPFM (GSEXPL ** Element0 GPXC Refl) $ \(Element0 d dsl) => public export InGX : GebAtom -> GWExpNL -> GWExpXL -> GWExpX -InGX a ns xs = InSPFM (GSEXP ** Element0 GPX Refl) $ \(Element0 d dsl) => +InGX a ns xs = InWTFM (GSEXP ** Element0 GPX Refl) $ \(Element0 d dsl) => case d of GDS => void $ case dsl of Refl impossible GDXA => InGA a @@ -1541,3 +4039,614 @@ gsexptoGExp = gsexptoGExpSl GSEXP public export Show GSExpX where show = show . gsexptoGExp + +-------------------------------------------------- +-------------------------------------------------- +---- Concepts as refinements of S-expressions ---- +-------------------------------------------------- +-------------------------------------------------- + +public export +data RAtom : Type where + -- Objects representing ADTs + RA_OBJ_0 : RAtom + RA_OBJ_1 : RAtom + RA_OBJ_C : RAtom + RA_OBJ_P : RAtom + RA_OBJ_EQ : RAtom + + -- Morphisms among ADTs + RA_FROM_0 : RAtom + RA_TO_1 : RAtom + RA_INJ_L : RAtom + RA_INJ_R : RAtom + RA_CASE : RAtom + RA_PROJ_L : RAtom + RA_PROJ_R : RAtom + RA_PAIR : RAtom + RA_DISTRIB : RAtom + +public export +RASize : Nat +RASize = 14 + +public export +RAFin : Type +RAFin = Fin RASize + +public export +RADecoder : FinDecoder RAtom RASize +RADecoder FZ = RA_OBJ_0 +RADecoder (FS FZ) = RA_OBJ_1 +RADecoder (FS (FS FZ)) = RA_OBJ_C +RADecoder (FS (FS (FS FZ))) = RA_OBJ_P +RADecoder (FS (FS (FS (FS FZ)))) = RA_OBJ_EQ +RADecoder (FS (FS (FS (FS (FS FZ))))) = RA_FROM_0 +RADecoder (FS (FS (FS (FS (FS (FS FZ)))))) = RA_TO_1 +RADecoder (FS (FS (FS (FS (FS (FS (FS FZ))))))) = RA_INJ_L +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))) = RA_INJ_R +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ))))))))) = RA_CASE +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))))) = RA_PROJ_L +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ))))))))))) = RA_PROJ_R +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))))))) = + RA_PAIR +RADecoder (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS FZ))))))))))))) = + RA_DISTRIB + +public export +RAEncoder : NatEncoder RADecoder +RAEncoder RA_OBJ_0 = (0 ** Refl ** Refl) +RAEncoder RA_OBJ_1 = (1 ** Refl ** Refl) +RAEncoder RA_OBJ_C = (2 ** Refl ** Refl) +RAEncoder RA_OBJ_P = (3 ** Refl ** Refl) +RAEncoder RA_OBJ_EQ = (4 ** Refl ** Refl) +RAEncoder RA_FROM_0 = (5 ** Refl ** Refl) +RAEncoder RA_TO_1 = (6 ** Refl ** Refl) +RAEncoder RA_INJ_L = (7 ** Refl ** Refl) +RAEncoder RA_INJ_R = (8 ** Refl ** Refl) +RAEncoder RA_CASE = (9 ** Refl ** Refl) +RAEncoder RA_PROJ_L = (10 ** Refl ** Refl) +RAEncoder RA_PROJ_R = (11 ** Refl ** Refl) +RAEncoder RA_PAIR = (12 ** Refl ** Refl) +RAEncoder RA_DISTRIB = (13 ** Refl ** Refl) + +public export +RAtomEncoding : FinDecEncoding RAtom RASize +RAtomEncoding = NatDecEncoding RADecoder RAEncoder + +public export +raToString : RAtom -> String +raToString RA_OBJ_0 = "RA_OBJ_0" +raToString RA_OBJ_1 = "RA_OBJ_1" +raToString RA_OBJ_C = "RA_OBJ_C" +raToString RA_OBJ_P = "RA_OBJ_P" +raToString RA_OBJ_EQ = "RA_OBJ_EQ" +raToString RA_FROM_0 = "RA_FROM_0" +raToString RA_TO_1 = "RA_TO_1" +raToString RA_INJ_L = "RA_INJ_L" +raToString RA_INJ_R = "RA_INJ_R" +raToString RA_CASE = "RA_CASE" +raToString RA_PROJ_L = "RA_PROJ_L" +raToString RA_PROJ_R = "RA_PROJ_R" +raToString RA_PAIR = "RA_PAIR" +raToString RA_DISTRIB = "RA_DISTRIB" + +public export +Show RAtom where + show a = raToString a + +public export +Eq RAtom where + (==) = fdeEq RAtomEncoding + +public export +Ord RAtom where + (<) = fdeLt RAtomEncoding + +public export +DecEq RAtom where + decEq = fdeDecEq RAtomEncoding + +public export +FRExp : Type -> Type +FRExp = FrSExpM RAtom + +public export +FRList : Type -> Type +FRList = FrSListM RAtom + +public export +RExp : Type +RExp = SExp RAtom + +public export +RList : Type +RList = SList RAtom + +------------------------------------ +------------------------------------ +---- Quiver-functor experiments ---- +------------------------------------ +------------------------------------ + +public export +data RObjF : (obj, morph : Type) -> Type where + RObj1 : RObjF obj morph + RObjPr : (a, b : obj) -> RObjF obj morph + RObjEq : (a, b : obj) -> (f, g : morph) -> RObjF obj morph + +public export +data RObjTrF : (obj, morph : Type) -> Type -> Type where + ROVar : var -> RObjTrF obj morph var + ROCom : RObjF obj morph -> RObjTrF obj morph var + +public export +data RMorphF : (obj, morph : Type) -> Type where + RMorphId : obj -> RMorphF obj morph + RMorphComp : (g, f : morph) -> RMorphF obj morph + RMorphTo1 : obj -> RMorphF obj morph + RMorphPairing : (f, g : morph) -> RMorphF obj morph + RMorphProjL : (a, b : obj) -> RMorphF obj morph + RMorphProjR : (a, b : obj) -> RMorphF obj morph + RMorphEqInjDom : (a, b : obj) -> (f, g : morph) -> RMorphF obj morph + RMorphEqInjCod : (a, b : obj) -> (f, g : morph) -> RMorphF obj morph + +public export +data RMorphTrF : (obj, morph : Type) -> Type -> Type where + RMVar : var -> RMorphTrF obj morph var + RMCom : RMorphF obj morph -> RMorphTrF obj morph var + +mutual + public export + data RObjFM : (ovar, mvar : Type) -> Type where + InFRO : + RObjTrF (RObjFM ovar mvar) (RMorphFM ovar mvar) ovar -> + RObjFM ovar mvar + + public export + data RMorphFM : (ovar, mvar : Type) -> Type where + InFRM : + RMorphTrF (RObjFM ovar mvar) (RMorphFM ovar mvar) mvar -> + RMorphFM ovar mvar + +public export +RObj : Type +RObj = RObjFM Void Void + +public export +RMorph : Type +RMorph = RMorphFM Void Void + +{- +public export +data RHasDomF : (obj, morph, hasDom, hasCod : Type) -> Type where + RHDId : (a : obj) -> RHasDomF obj morph hasDom hasCod + RHDComp : (g, f : morph) -> (a : obj) -> (ga : hasDom) -> (fa : hasCod) -> + RHasDomF obj morph hasDom hasCod + + {- +public export +rdomF : + (obj : Type) -> (morph : Type) -> + (dom : morph -> obj) -> (cod : morph -> obj) -> + RMorphF obj morph dom cod -> RObjTrF obj morph dom cod obj +rdomF obj morph dom cod (RMorphId a) = ROVar a +rdomF obj morph dom cod (RMorphComp g f prf) = ROVar $ dom f +rdomF obj morph dom cod (RMorphTo1 a) = ROVar a +rdomF obj morph dom cod (RMorphPairing f g prf) = ROVar $ dom f +rdomF obj morph dom cod (RMorphProjL a b) = ROCom $ RObjPr a b +rdomF obj morph dom cod (RMorphProjR a b) = ROCom $ RObjPr a b +rdomF obj morph dom cod (RMorphEqInjDom a b f g prf prf1 prf2 prf3) = + ROCom $ RObjEq a b f g prf prf1 prf2 prf3 +rdomF obj morph dom cod (RMorphEqInjCod a b f g prf prf1 prf2 prf3) = + ROCom $ RObjEq a b f g prf prf1 prf2 prf3 + -} + +public export +rhdomObjAlg : (obj, morph, hasDom, hasCod : Type) -> + RHasDomF obj morph hasDom hasCod -> + RObjTrF obj morph dom cod obj +rhdomObjAlg obj morph hasDom hasCod (RHDId a) = ROVar a +rhdomObjAlg obj morph hasDom hasCod (RHDComp g f a ga fa) = ?rhdomObjAlg_hole + +public export +rhdomMorphAlg : (obj, morph, hasDom, hasCod : Type) -> + RHasDomF obj morph hasDom hasCod -> + RMorphF obj morph dom cod +rhdomMorphAlg obj morph hasDom hasCod (RHDId a) = RMorphId a +rhdomMorphAlg obj morph hasDom hasCod (RHDComp g f a ga fa) = ?rhdomMorphAlg_hole + +public export +data RHasCodF : (obj, morph, hasDom, hasCod : Type) -> Type where + RHCId : (a : obj) -> RHasCodF obj morph hasDom hasCod + +{- +public export +rcodF : + (obj : Type) -> (morph : Type) -> + (dom : morph -> obj) -> (cod : morph -> obj) -> + RMorphF obj morph dom cod -> RObjTrF obj morph dom cod obj +rcodF obj morph dom cod (RMorphId a) = ROVar a +rcodF obj morph dom cod (RMorphComp g f prf) = ROVar $ cod g +rcodF obj morph dom cod (RMorphTo1 a) = ROCom RObj1 +rcodF obj morph dom cod (RMorphPairing f g prf) = ROCom $ RObjPr (cod f) (cod g) +rcodF obj morph dom cod (RMorphProjL a b) = ROVar a +rcodF obj morph dom cod (RMorphProjR a b) = ROVar b +rcodF obj morph dom cod (RMorphEqInjDom a b f g prf prf1 prf2 prf3) = ROVar a +rcodF obj morph dom cod (RMorphEqInjCod a b f g prf prf1 prf2 prf3) = ROVar b +-} + +public export +rhcodObjAlg : (obj, morph, hasDom, hasCod : Type) -> + RHasCodF obj morph hasDom hasCod -> + RObjTrF obj morph dom cod obj +rhcodObjAlg obj morph hasDom hasCod (RHCId a) = ROVar a + +public export +rhcodMorphAlg : (obj, morph, hasDom, hasCod : Type) -> + RHasCodF obj morph hasDom hasCod -> + RMorphF obj morph dom cod +rhcodMorphAlg obj morph hasDom hasCod (RHCId a) = RMorphId a + +mutual + public export + data RObj : Type where + InRO : RObjF RObj RMorph RHasDom RHasCod -> RObj + + public export + data RMorph : Type where + InRM : RMorphF RObj RMorph RHasDom RHasCod -> RMorph + + public export + data RHasDom : Type where + InRDV : + (f : RMorphF RObj RMorph RHasDom RHasCod) -> (a : RObj) -> + RHasDomF RObj RMorph RHasDom RHasCod -> + RHasDom + InRDC : + (f : RMorphF RObj RMorph RHasDom RHasCod) -> + (a : RObjF RObj RMorph RHasDom RHasCod) -> + RHasDomF RObj RMorph RHasDom RHasCod -> + RHasDom + + public export + data RHasCod : Type where + InRCV : + (f : RMorphF RObj RMorph RHasDom RHasCod) -> (a : RObj) -> + RHasCodF RObj RMorph RHasDom RHasCod -> + RHasCod + InRCC : + (f : RMorphF RObj RMorph RHasDom RHasCod) -> + (a : RObjF RObj RMorph RHasDom RHasCod) -> + RHasCodF RObj RMorph RHasDom RHasCod -> + RHasCod + +{- + public export + rdom : RMorph -> RObj + rdom (InRM f) with (rdomF RObj RMorph rdom rcod f) + rdom (InRM f) | ROCom dom = InRO dom + rdom (InRM f) | ROVar dom = dom + + public export + rcod : RMorph -> RObj + rcod (InRM f) with (rcodF RObj RMorph rdom rcod f) + rcod (InRM f) | ROCom cod = InRO cod + rcod (InRM f) | ROVar cod = cod + -} + -} + +---------------------------- +---- Generic generators ---- +---------------------------- + +-- Given two types (for example, one of objects and one of morphisms), +-- generate a (new) type of objects. +public export +data FinLimSl : Type where + FLSObj : FinLimSl + FLSMorph : FinLimSl + +public export +ObjGenSigDom : Type +ObjGenSigDom = FinLimSl + +public export +ObjGenSigCod : Type +ObjGenSigCod = Unit + +public export +ObjGenSig : Type +ObjGenSig = SlicePolyFunc ObjGenSigDom ObjGenSigCod + +-- Given a type (of objects) and a type (of morphisms), generate a type +-- (of morphisms). +public export +MorphGenSigDom : Type +MorphGenSigDom = FinLimSl + +public export +MorphGenSigCod : Type +MorphGenSigCod = Unit + +public export +MorphGenSig : Type +MorphGenSig = SlicePolyFunc MorphGenSigDom MorphGenSigCod + +--------------------------------- +---- Example : finite limits ---- +--------------------------------- + +-- An example object generator with a terminal object, pairwise products, +-- and equalizers. +public export +data FinLimObjPos : ObjGenSigCod -> Type where + FLOP1 : FinLimObjPos () + FLOPProd : FinLimObjPos () + FLOPEq : FinLimObjPos () + +public export +FinLimObjDir : Sigma FinLimObjPos -> Type +-- The terminal object has no directions +FinLimObjDir (() ** FLOP1) = Void +-- A pairwise product has two directions (false is the left object; +-- true is the right object) +FinLimObjDir (() ** FLOPProd) = BoolCP +-- An equalizer has two directions, two objects and two morphisms: we'll +-- use pairs, where the left pair is the pair of objects and the right pair +-- is the pair of morphisms. +FinLimObjDir (() ** FLOPEq) = ProductMonad BoolCP + +public export +FinLimObjAssign : Sigma FinLimObjDir -> ObjGenSigDom +FinLimObjAssign ((() ** FLOP1) ** v) = void v +FinLimObjAssign ((() ** FLOPProd) ** od) = + -- Both directions of a pairwise product are objects. + FLSObj +FinLimObjAssign ((() ** FLOPEq) ** ((Left u), md)) = + -- The left two directions of an equalizer are objects. + case u of () => FLSObj +FinLimObjAssign ((() ** FLOPEq) ** ((Right u), md)) = + -- The right two directions of an equalizer are morphisms. + case u of () => FLSMorph + +public export +FinLimObjF : ObjGenSig +FinLimObjF = (FinLimObjPos ** FinLimObjDir ** FinLimObjAssign) + +-- The morphisms of this category have the following positions: +-- - The unique morphism to the terminal object +-- - One product introduction rule (pairing) +-- - Two product elimination rule (projections) +-- - Two equalizer elimination rules (the injection to the domain, +-- which forgets the equalization, and the injection to the codomain, +-- which equalization guarantees is equal to the composition of +-- either of the equalized morphisms after the injection to the +-- domain -- note that this means that the injection to the codomain +-- includes a guarantee of a particular equalization, which means that +-- it is _also_ an equalizer introduction rule) +public export +data FinLimMorph : Type where + FLMId : FinLimMorph + FLMCompose : FinLimMorph + FLMTo1 : FinLimMorph + FLMPairing : FinLimMorph + FLMProjL : FinLimMorph + FLMProjR : FinLimMorph + FLMEqInjDom : FinLimMorph -- equalizer elimination (forgetful) + FLMEqInjCod : FinLimMorph -- equalizer elimination _and_ introduction + +public export +FinLimMorphPos : MorphGenSigCod -> Type +FinLimMorphPos () = FinLimMorph + +public export +FinLimMorphDir : Sigma FinLimMorphPos -> Type +-- The id morphism to the terminal object has one direction: +-- an object, which is both its domain and its codomain +FinLimMorphDir (() ** FLMId) = Unit +-- The compose morphism has two directions: the two morphisms +-- being composed (false is the left side, which is the following +-- morphism; true is the right side, which is the preceding morphism) +FinLimMorphDir (() ** FLMCompose) = BoolCP +-- The unique morphism to the terminal object has one direction: +-- an object, which is its domain +FinLimMorphDir (() ** FLMTo1) = Unit +-- The pairing morphism has two directions: the two morphisms +-- which generate each side of the codomain +FinLimMorphDir (() ** FLMPairing) = BoolCP +-- The left projection has two directions: both objects, which +-- are the left and right sides of the domain +FinLimMorphDir (() ** FLMProjL) = BoolCP +-- The right projection has two directions: both objects, which +-- are the left and right sides of the domain +FinLimMorphDir (() ** FLMProjR) = BoolCP +-- The injection to the domain of an equalizer has one direction: +-- the object which is the equalizer itself +FinLimMorphDir (() ** FLMEqInjDom) = Unit +-- The injection to the domain of an equalizer has one direction: +-- the object which is the equalizer itself +FinLimMorphDir (() ** FLMEqInjCod) = Unit + +public export +FinLimMorphAssign : Sigma FinLimMorphDir -> MorphGenSigDom +-- The id morphism's one direction is an object +FinLimMorphAssign ((() ** FLMId) ** d) = FLSObj +-- The compose morphism's two directions are both morphisms +FinLimMorphAssign ((() ** FLMCompose) ** d) = FLSMorph +-- The unique morphism to the terminal object's one direction is an object +FinLimMorphAssign ((() ** FLMTo1) ** ()) = FLSObj +-- Both of the pairing morphism's directions are morphisms +FinLimMorphAssign ((() ** FLMPairing) ** d) = FLSMorph +-- Both of the projection morphisms' directions are objects +FinLimMorphAssign ((() ** FLMProjL) ** d) = FLSObj +FinLimMorphAssign ((() ** FLMProjR) ** d) = FLSObj +-- The one direction of each morphism from an equalizer is an object +-- (the equalizer itself) +FinLimMorphAssign ((() ** FLMEqInjDom) ** ()) = FLSObj +FinLimMorphAssign ((() ** FLMEqInjCod) ** ()) = FLSObj + +public export +FinLimMorphF : MorphGenSig +FinLimMorphF = (FinLimMorphPos ** FinLimMorphDir ** FinLimMorphAssign) + +public export +FinCatSigGenPos : FinLimSl -> Type +FinCatSigGenPos FLSObj = FinLimObjPos () +FinCatSigGenPos FLSMorph = FinLimMorphPos () + +public export +FinCatSigGenDir : Sigma {a=FinLimSl} FinCatSigGenPos -> Type +FinCatSigGenDir (FLSObj ** d) = FinLimObjDir (() ** d) +FinCatSigGenDir (FLSMorph ** d) = FinLimMorphDir (() ** d) + +public export +FinCatSigGenAssign : Sigma FinCatSigGenDir -> FinLimSl +FinCatSigGenAssign ((FLSObj ** i) ** d) = FinLimObjAssign ((() ** i) ** d) +FinCatSigGenAssign ((FLSMorph ** i) ** d) = FinLimMorphAssign ((() ** i) ** d) + +public export +FinCatSigGenF : SlicePolyEndoFunc FinLimSl +FinCatSigGenF = (FinCatSigGenPos ** FinCatSigGenDir ** FinCatSigGenAssign) + +public export +FinCatSig : SliceObj FinLimSl +FinCatSig = SPFMu FinCatSigGenF + +public export +FinCatObjSig : Type +FinCatObjSig = FinCatSig FLSObj + +public export +FinCatMorphSig : Type +FinCatMorphSig = FinCatSig FLSMorph + +------------------------------- +---- Second-order versions ---- +------------------------------- + +-- Slices of second-order finite-limit-category expressions. +public export +data FinLimSl2 : Type where + FLS2f : FinLimSl -> FinLimSl2 -- first-order (unchecked) slices + FLS2u : FinLimSl -> FinLimSl2 -- second-order (unchecked) slices + +public export +FinLimCat2Pos : FinLimSl2 -> Type +FinLimCat2Pos (FLS2f sl) = FinCatSigGenPos sl +FinLimCat2Pos (FLS2u x) = ?FinLimCat2Pos_hole_1 + +public export +FinLimMorphParamDir : Type +FinLimMorphParamDir = (FinCatObjSig, FinCatObjSig) + +public export +FinLimCheckableMorphDir : Sigma FinLimMorphPos -> Type +FinLimCheckableMorphDir i = Either FinLimMorphParamDir (FinLimMorphDir i) + +public export +FinLimCheckableMorphAssign : Sigma FinLimCheckableMorphDir -> MorphGenSigDom +FinLimCheckableMorphAssign ((() ** i) ** (Left x)) = ?FinLimCheckableMorphAssign_hole_0 +FinLimCheckableMorphAssign ((() ** i) ** (Right x)) = ?FinLimCheckableMorphAssign_hole_1 + +public export +FinLimCheckableMorphF : MorphGenSig +FinLimCheckableMorphF = + (FinLimMorphPos ** FinLimCheckableMorphDir ** FinLimCheckableMorphAssign) + +public export +FinCatSigAlg : SliceObj FinLimSl -> Type +FinCatSigAlg = SPFAlg FinCatSigGenF + +public export +FinCatSigCheckSlice : SliceObj FinLimSl +FinCatSigCheckSlice FLSObj = Bool +FinCatSigCheckSlice FLSMorph = FinCatObjSig -> Bool + +public export +FinCatSigCheckAlg : FinCatSigAlg FinCatSigCheckSlice +-- The expression consisting just of the representation of the terminal +-- object is always valid (and always represents the terminal object). +FinCatSigCheckAlg FLSObj (FLOP1 ** d) = True +-- An expression representing the product of two objects is valid if and +-- only if both of the expressions representing the subobjects are valid. +FinCatSigCheckAlg FLSObj (FLOPProd ** d) = d (Left ()) && d (Right ()) +-- An expression representing an equalizer is valid if and only if: +-- - The expressions representing the two subobjects are valid +-- - The expressions representing the two morphisms are valid +-- - The two morphisms both have the first subobject as their domain +-- and the second subobject as their codomain +FinCatSigCheckAlg FLSObj (FLOPEq ** d) = ?FinCatSigCheckAlg_hole_prodr +-- An expression representing an identity morphism is valid if and +-- only if the object which represents both its domain and its codomain +-- is valid. +FinCatSigCheckAlg FLSMorph (FLMId ** d) = ?FinCatSigCheckAlg_hole_id +FinCatSigCheckAlg FLSMorph (FLMCompose ** d) = ?FinCatSigCheckAlg_hole_compose +FinCatSigCheckAlg FLSMorph (FLMTo1 ** d) = ?FinCatSigCheckAlg_hole_to1 +FinCatSigCheckAlg FLSMorph (FLMPairing ** d) = ?FinCatSigCheckAlg_hole_mkpair +FinCatSigCheckAlg FLSMorph (FLMProjL ** d) = ?FinCatSigCheckAlg_hole_projl +FinCatSigCheckAlg FLSMorph (FLMProjR ** d) = ?FinCatSigCheckAlg_hole_projr +FinCatSigCheckAlg FLSMorph (FLMEqInjDom ** d) = ?FinCatSigCheckAlg_hole_injd +FinCatSigCheckAlg FLSMorph (FLMEqInjCod ** d) = ?FinCatSigCheckAlg_hole_injc + +public export +finCatSigCheck : SliceMorphism FinCatSig FinCatSigCheckSlice +finCatSigCheck = spfCata FinCatSigCheckAlg + +public export +finCatSigCheckObj : FinCatObjSig -> Bool +finCatSigCheckObj = finCatSigCheck FLSObj + +public export +finCatSigCheckMorph : FinCatObjSig -> FinCatMorphSig -> Bool +finCatSigCheckMorph = flip $ finCatSigCheck FLSMorph + +------------------------------------------- +------------------------------------------- +---- Geb as double category (or more?) ---- +------------------------------------------- +------------------------------------------- + +public export +BoolF : Type -> Type +BoolF = const Bool + +---------------------------- +---------------------------- +---- Product categories ---- +---------------------------- +---------------------------- + +-- Given an object of objects of a category, produce the object of +-- objects of its product category (with itself). +public export +PCatObj : PolyFunc +PCatObj = PFHomArena BoolCP + +public export +PCatMorphFPos : Type +PCatMorphFPos = Unit + +public export +PCatMorph : PolyFunc +PCatMorph = PFHomArena BoolCP + +public export +PCatDom : (obj : Type) -> (morph : Type) -> + (dom : morph -> obj) -> (cod : morph -> obj) -> + InterpPolyFunc PCatMorph morph -> InterpPolyFunc PCatObj obj +PCatDom obj morph dom cod (() ** x) = (() ** dom . x) + +public export +PCatCod : (obj : Type) -> (morph : Type) -> + (dom : morph -> obj) -> (cod : morph -> obj) -> + InterpPolyFunc PCatMorph morph -> InterpPolyFunc PCatObj obj +PCatCod obj morph dom cod (() ** x) = (() ** cod . x) + +public export +PCatSig : (obj : Type) -> (morph : Type) -> + (dom : morph -> obj) -> (cod : morph -> obj) -> + InterpPolyFunc PCatMorph morph -> + (InterpPolyFunc PCatObj obj, InterpPolyFunc PCatObj obj) +PCatSig obj morph dom cod x = + (PCatDom obj morph dom cod x, PCatCod obj morph dom cod x) diff --git a/geb-idris/src/LanguageDef/GenPolyFunc.idr b/geb-idris/src/LanguageDef/GenPolyFunc.idr new file mode 100644 index 000000000..9b5aa189a --- /dev/null +++ b/geb-idris/src/LanguageDef/GenPolyFunc.idr @@ -0,0 +1,13 @@ +module LanguageDef.GenPolyFunc + +import Library.IdrisUtils +import Library.IdrisCategories +import public LanguageDef.Atom +import public LanguageDef.ProgFinSet +import public LanguageDef.PolyCat +import public LanguageDef.Syntax +import public LanguageDef.DiagramCat +import public LanguageDef.GebTopos +import public LanguageDef.Adjunctions + +%default total diff --git a/geb-idris/src/LanguageDef/PolyCat.idr b/geb-idris/src/LanguageDef/PolyCat.idr index 813dd599f..035386704 100644 --- a/geb-idris/src/LanguageDef/PolyCat.idr +++ b/geb-idris/src/LanguageDef/PolyCat.idr @@ -2561,78 +2561,6 @@ InterpPolyRKan p q a rk b qf = --------------------------------------- --------------------------------------- ---------------------------------------------------------- ----- Dependent polynomial functors in Idris's `Type` ---- ---------------------------------------------------------- - --- Dependent product in terms of a predicate instead of a morphism. -public export -PredDepProdF : {a : Type} -> (p : SliceObj a) -> SliceFunctor (Sigma {a} p) a -PredDepProdF {a} p slp elema = - Pi {a=(p elema)} (BaseChangeF (MkDPair elema) slp) - --- Dependent coproduct in terms of a predicate instead of a morphism. -public export -PredDepCoprodF : {a : Type} -> (p : SliceObj a) -> SliceFunctor (Sigma {a} p) a -PredDepCoprodF {a} p slp elema = - Sigma {a=(p elema)} (BaseChangeF (MkDPair elema) slp) - --- A dependent polynomial functor in terms of predicates instead of morphisms. -public export -PredDepPolyF : {parambase, posbase : Type} -> - (posdep : SliceObj posbase) -> - (dirdep : SliceObj (Sigma posdep)) -> - (assign : Sigma dirdep -> parambase) -> - SliceFunctor parambase posbase -PredDepPolyF {parambase} {posbase} posdep dirdep assign = - PredDepCoprodF {a=posbase} posdep - . PredDepProdF {a=(Sigma posdep)} dirdep - . BaseChangeF assign - --- The same function as `PredDepPolyF`, but compressed into a single computation --- purely as documentation for cases in which this might be more clear. -public export -PredDepPolyF' : {parambase, posbase : Type} -> - (posdep : SliceObj posbase) -> - (dirdep : SliceObj (Sigma posdep)) -> - (assign : Sigma dirdep -> parambase) -> - SliceFunctor parambase posbase -PredDepPolyF' posdep dirdep assign parampred posi = - (pos : posdep posi ** - ((dir : dirdep (posi ** pos)) -> parampred (assign ((posi ** pos) ** dir)))) - -public export -PredDepPolyF'_correct : {parambase, posbase : Type} -> - (posdep : SliceObj posbase) -> - (dirdep : SliceObj (Sigma posdep)) -> - (assign : Sigma dirdep -> parambase) -> - (parampred : SliceObj parambase) -> - (posi : posbase) -> - PredDepPolyF posdep dirdep assign parampred posi = - PredDepPolyF' posdep dirdep assign parampred posi -PredDepPolyF'_correct posdep dirdep assign parampred posi = Refl - --- The morphism-map component of the functor induced by a `PredDepPolyF`. -PredDepPolyFMap : {parambase, posbase : Type} -> - (posdep : SliceObj posbase) -> - (dirdep : SliceObj (Sigma posdep)) -> - (assign : Sigma dirdep -> parambase) -> - (p, p' : SliceObj parambase) -> - SliceMorphism p p' -> - SliceMorphism - (PredDepPolyF posdep dirdep assign p) - (PredDepPolyF posdep dirdep assign p') -PredDepPolyFMap posdep dirdep assign p p' m posi (pos ** dir) = - (pos ** \di => m (assign ((posi ** pos) ** di)) (dir di)) - -public export -PredDepPolyEndoF : {base : Type} -> - (posdep : SliceObj base) -> - (dirdep : SliceObj (Sigma posdep)) -> - (assign : Sigma dirdep -> base) -> - SliceFunctor base base -PredDepPolyEndoF {base} = PredDepPolyF {parambase=base} {posbase=base} - ----------------------------------------------------------- ---- Refined versions of dependent polynomial functors ---- ----------------------------------------------------------- @@ -2884,94 +2812,11 @@ InterpSPFMap {a} {b} spf {sa} {sa'} = PredDepPolyFMap {parambase=a} {posbase=b} (spfPos spf) (spfDir spf) (spfAssign spf) sa sa' ------------------------------------------------------- ----- Dependent polynomial endofunctors as W-types ---- ------------------------------------------------------- - -public export -record WTypeFunc (parambase, posbase : Type) where - constructor MkWTF - wtPos : Type - wtDir : Type - wtAssign : wtDir -> parambase - wtDirSlice : wtDir -> wtPos - wtPosSlice : wtPos -> posbase - -public export -WTypeEndoFunc : Type -> Type -WTypeEndoFunc base = WTypeFunc base base - -public export -InterpWTF : {parambase, posbase : Type} -> - WTypeFunc parambase posbase -> SliceFunctor parambase posbase -InterpWTF {parambase} {posbase} (MkWTF pos dir assign dsl psl) sl ib = - (i : PreImage {a=pos} {b=posbase} psl ib ** - (d : PreImage {a=dir} {b=pos} dsl (fst0 i)) -> - sl $ assign $ fst0 d) - -public export -WTFtoSPF : {parambase, posbase : Type} -> - WTypeFunc parambase posbase -> SlicePolyFunc parambase posbase -WTFtoSPF {parambase} {posbase} (MkWTF pos dir assign dsl psl) = - (\i => PreImage {a=pos} {b=posbase} psl i ** - \x => PreImage {a=dir} {b=pos} dsl $ fst0 $ snd x ** - \d => assign $ fst0 $ snd d) - -public export -SPFtoWTF : {parambase, posbase : Type} -> - SlicePolyFunc parambase posbase -> WTypeFunc parambase posbase -SPFtoWTF (posdep ** dirdep ** assign) = - MkWTF - (Sigma {a=posbase} posdep) - (Sigma {a=(Sigma {a=posbase} posdep)} dirdep) - assign - fst - fst - -public export -InterpWTFtoSPF : {parambase, posbase : Type} -> - (wtf : WTypeFunc parambase posbase) -> - (sl : SliceObj parambase) -> (ib : posbase) -> - InterpSPFunc {a=parambase} {b=posbase} - (WTFtoSPF {parambase} {posbase} wtf) sl ib -> - InterpWTF {parambase} {posbase} wtf sl ib -InterpWTFtoSPF (MkWTF pos dir assign dsl psl) sl ib = id - -public export -InterpWTFtoSPFInv : {parambase, posbase : Type} -> - (wtf : WTypeFunc parambase posbase) -> - (sl : SliceObj parambase) -> (ib : posbase) -> - InterpWTF {parambase} {posbase} wtf sl ib -> - InterpSPFunc {a=parambase} {b=posbase} - (WTFtoSPF {parambase} {posbase} wtf) sl ib -InterpWTFtoSPFInv (MkWTF pos dir assign dsl psl) sl ib = id - -public export -InterpSPFtoWTF : {parambase, posbase : Type} -> - (spf : SlicePolyFunc parambase posbase) -> - (sl : SliceObj parambase) -> (ib : posbase) -> - InterpWTF {parambase} {posbase} (SPFtoWTF {parambase} {posbase} spf) sl ib -> - InterpSPFunc {a=parambase} {b=posbase} spf sl ib -InterpSPFtoWTF {parambase} {posbase} (posdep ** dirdep ** assign) sl ib - (Element0 {type=(Sigma {a=posbase} posdep)} (ib' ** i) eq ** p) = - (rewrite sym eq in i ** - \d => p $ - Element0 ((ib ** rewrite sym eq in i) ** d) (rewrite sym eq in Refl)) - -public export -InterpSPFtoWTFInv : {parambase, posbase : Type} -> - (spf : SlicePolyFunc parambase posbase) -> - (sl : SliceObj parambase) -> (ib : posbase) -> - InterpSPFunc {a=parambase} {b=posbase} spf sl ib -> - InterpWTF {parambase} {posbase} (SPFtoWTF {parambase} {posbase} spf) sl ib -InterpSPFtoWTFInv {parambase} {posbase} (posdep ** dirdep ** assign) sl ib - (i ** d) = - (Element0 (ib ** i) Refl ** - \(Element0 (i' ** di) deq) => rewrite deq in d $ rewrite sym deq in di) - +----------------------------------------------------- ----------------------------------------------------- ---- Parameterized dependent polynomial functors ---- ----------------------------------------------------- +----------------------------------------------------- public export ParamSPF : {a : Type} -> (x, y : SliceObj a) -> Type @@ -3215,29 +3060,26 @@ public export SPFSliceTerminal : (x : Type) -> SlicePolyEndoFunc x SPFSliceTerminal x = (const Unit ** const Void ** \x => void $ snd x) --- The coproduct in the category of polynomial endofunctors on --- the slice category `Type/x`. public export -SPFSliceCoproduct : {a : Type} -> - SlicePolyEndoFunc x -> SlicePolyEndoFunc x -> SlicePolyEndoFunc x -SPFSliceCoproduct {a} (pd ** dd ** asn) (pd' ** dd' ** asn') = +SPFSliceCoproduct : {x, y : Type} -> + SlicePolyFunc x y -> SlicePolyFunc x y -> SlicePolyFunc x y +SPFSliceCoproduct {x} {y} (pd ** dd ** asn) (pd' ** dd' ** asn') = (\i => Either (pd i) (pd' i) ** \(i ** d) => (case d of Left d' => dd (i ** d') Right d' => dd' (i ** d')) ** \((i ** d) ** dd) => (case d of - Left d' => i - Right d' => i)) + Left d' => asn ((i ** d') ** dd) + Right d' => asn' ((i ** d') ** dd))) --- The product in the category of polynomial endofunctors on --- the slice category `Type/x`. public export -SPFSliceProduct : {a : Type} -> - SlicePolyEndoFunc x -> SlicePolyEndoFunc x -> SlicePolyEndoFunc x -SPFSliceProduct {a} (pd ** dd ** asn) (pd' ** dd' ** asn') = +SPFSliceProduct : {x, y, z : Type} -> + SlicePolyFunc x z -> SlicePolyFunc y z -> SlicePolyFunc (x, y) z +SPFSliceProduct {x} (pd ** dd ** asn) (pd' ** dd' ** asn') = (\i => (pd i, pd' i) ** \(i ** (d, d')) => (dd (i ** d), dd' (i ** d')) ** - \((i ** d) ** dd) => i) + \((i ** (d, d')) ** (dd, dd')) => + (asn ((i ** d) ** dd), asn' ((i ** d') ** dd'))) ------------------------------------------------------------- ------------------------------------------------------------- diff --git a/geb-idris/src/LanguageDef/ProgFinSet.idr b/geb-idris/src/LanguageDef/ProgFinSet.idr index b4a628774..d52ff616a 100644 --- a/geb-idris/src/LanguageDef/ProgFinSet.idr +++ b/geb-idris/src/LanguageDef/ProgFinSet.idr @@ -18,43 +18,43 @@ import public LanguageDef.Atom ------------------------------------------------------ public export -data BicartDistObjPos : Type where - BCDObjInitial : BicartDistObjPos - BCDObjTerminal : BicartDistObjPos - BCDObjCoproduct : BicartDistObjPos - BCDObjProduct : BicartDistObjPos +data BCDOPos : Type where + BCDO_0 : BCDOPos + BCDO_1 : BCDOPos + BCDO_C : BCDOPos + BCDO_P : BCDOPos public export -Show BicartDistObjPos where - show BCDObjInitial = "0" - show BCDObjTerminal = "1" - show BCDObjCoproduct = "+" - show BCDObjProduct = "*" +Show BCDOPos where + show BCDO_0 = "0" + show BCDO_1 = "1" + show BCDO_C = "+" + show BCDO_P = "*" public export BCDOPosSz : Nat BCDOPosSz = 4 public export -BCDOFinDecoder : FinDecoder BicartDistObjPos BCDOPosSz -BCDOFinDecoder FZ = BCDObjInitial -BCDOFinDecoder (FS FZ) = BCDObjTerminal -BCDOFinDecoder (FS (FS FZ)) = BCDObjCoproduct -BCDOFinDecoder (FS (FS (FS FZ))) = BCDObjProduct +BCDOFinDecoder : FinDecoder BCDOPos BCDOPosSz +BCDOFinDecoder FZ = BCDO_0 +BCDOFinDecoder (FS FZ) = BCDO_1 +BCDOFinDecoder (FS (FS FZ)) = BCDO_C +BCDOFinDecoder (FS (FS (FS FZ))) = BCDO_P public export BCDONatEncoder : NatEncoder BCDOFinDecoder -BCDONatEncoder BCDObjInitial = (0 ** Refl ** Refl) -BCDONatEncoder BCDObjTerminal = (1 ** Refl ** Refl) -BCDONatEncoder BCDObjCoproduct = (2 ** Refl ** Refl) -BCDONatEncoder BCDObjProduct = (3 ** Refl ** Refl) +BCDONatEncoder BCDO_0 = (0 ** Refl ** Refl) +BCDONatEncoder BCDO_1 = (1 ** Refl ** Refl) +BCDONatEncoder BCDO_C = (2 ** Refl ** Refl) +BCDONatEncoder BCDO_P = (3 ** Refl ** Refl) public export -BCDOFinDecEncoding : FinDecEncoding BicartDistObjPos BCDOPosSz +BCDOFinDecEncoding : FinDecEncoding BCDOPos BCDOPosSz BCDOFinDecEncoding = NatDecEncoding BCDOFinDecoder BCDONatEncoder public export -DecEq BicartDistObjPos where +DecEq BCDOPos where decEq = fdeDecEq BCDOFinDecEncoding public export @@ -98,15 +98,15 @@ Eq BicartDistProductDir where _ == _ = False public export -BicartDistObjDir : SliceObj BicartDistObjPos -BicartDistObjDir BCDObjInitial = BicartDistInitialDir -BicartDistObjDir BCDObjTerminal = BicartDistTerminalDir -BicartDistObjDir BCDObjCoproduct = BicartDistCoproductDir -BicartDistObjDir BCDObjProduct = BicartDistProductDir +BicartDistObjDir : SliceObj BCDOPos +BicartDistObjDir BCDO_0 = BicartDistInitialDir +BicartDistObjDir BCDO_1 = BicartDistTerminalDir +BicartDistObjDir BCDO_C = BicartDistCoproductDir +BicartDistObjDir BCDO_P = BicartDistProductDir public export BicartDistObjF : PolyFunc -BicartDistObjF = (BicartDistObjPos ** BicartDistObjDir) +BicartDistObjF = (BCDOPos ** BicartDistObjDir) public export BicartDistObj : Type @@ -122,12 +122,12 @@ bcdoCata = pfCata {p=BicartDistObjF} public export BCDOShowAlg : BCDOAlg String -BCDOShowAlg BCDObjInitial dir = show BCDObjInitial -BCDOShowAlg BCDObjTerminal dir = show BCDObjTerminal -BCDOShowAlg BCDObjCoproduct dir = - "[" ++ dir BCDCopL ++ " " ++ show BCDObjCoproduct ++ " " ++ dir BCDCopR ++ "]" -BCDOShowAlg BCDObjProduct dir = - "(" ++ dir BCDProd1 ++ " " ++ show BCDObjProduct ++ " " ++ dir BCDProd2 ++ ")" +BCDOShowAlg BCDO_0 dir = show BCDO_0 +BCDOShowAlg BCDO_1 dir = show BCDO_1 +BCDOShowAlg BCDO_C dir = + "[" ++ dir BCDCopL ++ " " ++ show BCDO_C ++ " " ++ dir BCDCopR ++ "]" +BCDOShowAlg BCDO_P dir = + "(" ++ dir BCDProd1 ++ " " ++ show BCDO_P ++ " " ++ dir BCDProd2 ++ ")" public export bcdoShow : BicartDistObj -> String @@ -150,13 +150,13 @@ public export BCDOEqAlg : PFProductBoolAlg BicartDistObjF BicartDistObjF BCDOEqAlg = [ - ((BCDObjInitial, BCDObjInitial) ** + ((BCDO_0, BCDO_0) ** []) - , ((BCDObjTerminal, BCDObjTerminal) ** + , ((BCDO_1, BCDO_1) ** []) - , ((BCDObjCoproduct, BCDObjCoproduct) ** + , ((BCDO_C, BCDO_C) ** [ (BCDCopL, BCDCopL), (BCDCopR, BCDCopR) ]) - , ((BCDObjProduct, BCDObjProduct) ** + , ((BCDO_P, BCDO_P) ** [ (BCDProd1, BCDProd1), (BCDProd2, BCDProd2) ] ) ] @@ -176,43 +176,43 @@ Eq BicartDistObj where ---------------------------------------------------------------------- public export -data BicartDistTermPos : Type where - BCDTermUnit : BicartDistTermPos - BCDTermLeft : BicartDistTermPos - BCDTermRight : BicartDistTermPos - BCDTermPair : BicartDistTermPos +data BCDTPos : Type where + BCDT_U : BCDTPos + BCDT_L : BCDTPos + BCDT_R : BCDTPos + BCDT_P : BCDTPos public export -Show BicartDistTermPos where - show BCDTermUnit = "_" - show BCDTermLeft = "l" - show BCDTermRight = "r" - show BCDTermPair = "," +Show BCDTPos where + show BCDT_U = "_" + show BCDT_L = "l" + show BCDT_R = "r" + show BCDT_P = "," public export BCDTPosSz : Nat BCDTPosSz = 4 public export -BCDTFinDecoder : FinDecoder BicartDistTermPos BCDTPosSz -BCDTFinDecoder FZ = BCDTermUnit -BCDTFinDecoder (FS FZ) = BCDTermLeft -BCDTFinDecoder (FS (FS FZ)) = BCDTermRight -BCDTFinDecoder (FS (FS (FS FZ))) = BCDTermPair +BCDTFinDecoder : FinDecoder BCDTPos BCDTPosSz +BCDTFinDecoder FZ = BCDT_U +BCDTFinDecoder (FS FZ) = BCDT_L +BCDTFinDecoder (FS (FS FZ)) = BCDT_R +BCDTFinDecoder (FS (FS (FS FZ))) = BCDT_P public export BCDTNatEncoder : NatEncoder BCDTFinDecoder -BCDTNatEncoder BCDTermUnit = (0 ** Refl ** Refl) -BCDTNatEncoder BCDTermLeft = (1 ** Refl ** Refl) -BCDTNatEncoder BCDTermRight = (2 ** Refl ** Refl) -BCDTNatEncoder BCDTermPair = (3 ** Refl ** Refl) +BCDTNatEncoder BCDT_U = (0 ** Refl ** Refl) +BCDTNatEncoder BCDT_L = (1 ** Refl ** Refl) +BCDTNatEncoder BCDT_R = (2 ** Refl ** Refl) +BCDTNatEncoder BCDT_P = (3 ** Refl ** Refl) public export -BCDTFinDecEncoding : FinDecEncoding BicartDistTermPos BCDTPosSz +BCDTFinDecEncoding : FinDecEncoding BCDTPos BCDTPosSz BCDTFinDecEncoding = NatDecEncoding BCDTFinDecoder BCDTNatEncoder public export -DecEq BicartDistTermPos where +DecEq BCDTPos where decEq = fdeDecEq BCDTFinDecEncoding public export @@ -225,7 +225,7 @@ data BicartDistTermLeftDir : Type where public export Show BicartDistTermLeftDir where - show BCDTermL = show BCDTermLeft + show BCDTermL = show BCDT_L public export Eq BicartDistTermLeftDir where @@ -237,7 +237,7 @@ data BicartDistTermRightDir : Type where public export Show BicartDistTermRightDir where - show BCDTermR = show BCDTermRight + show BCDTermR = show BCDT_R public export Eq BicartDistTermRightDir where @@ -260,15 +260,15 @@ Eq BicartDistTermPairDir where _ == _ = False public export -BicartDistTermDir : SliceObj BicartDistTermPos -BicartDistTermDir BCDTermUnit = BicartDistTermUnitDir -BicartDistTermDir BCDTermLeft = BicartDistTermLeftDir -BicartDistTermDir BCDTermRight = BicartDistTermRightDir -BicartDistTermDir BCDTermPair = BicartDistTermPairDir +BicartDistTermDir : SliceObj BCDTPos +BicartDistTermDir BCDT_U = BicartDistTermUnitDir +BicartDistTermDir BCDT_L = BicartDistTermLeftDir +BicartDistTermDir BCDT_R = BicartDistTermRightDir +BicartDistTermDir BCDT_P = BicartDistTermPairDir public export BicartDistTermF : PolyFunc -BicartDistTermF = (BicartDistTermPos ** BicartDistTermDir) +BicartDistTermF = (BCDTPos ** BicartDistTermDir) public export BicartDistTerm : Type @@ -284,14 +284,14 @@ bicartDistTermCata = pfCata {p=BicartDistTermF} public export BCDTShowAlg : BicartDistTermAlg String -BCDTShowAlg BCDTermUnit dir = - show BCDTermUnit -BCDTShowAlg BCDTermLeft dir = - show BCDTermLeft ++ "[" ++ dir BCDTermL ++ "]" -BCDTShowAlg BCDTermRight dir = - show BCDTermRight ++ "[" ++ dir BCDTermR ++ "]" -BCDTShowAlg BCDTermPair dir = - "(" ++ dir BCDTerm1 ++ " " ++ show BCDTermPair ++ " " ++ dir BCDTerm2 ++ ")" +BCDTShowAlg BCDT_U dir = + show BCDT_U +BCDTShowAlg BCDT_L dir = + show BCDT_L ++ "[" ++ dir BCDTermL ++ "]" +BCDTShowAlg BCDT_R dir = + show BCDT_R ++ "[" ++ dir BCDTermR ++ "]" +BCDTShowAlg BCDT_P dir = + "(" ++ dir BCDTerm1 ++ " " ++ show BCDT_P ++ " " ++ dir BCDTerm2 ++ ")" public export bcdtShow : BicartDistTerm -> String @@ -314,13 +314,13 @@ public export BCDTEqAlg : PFProductBoolAlg BicartDistTermF BicartDistTermF BCDTEqAlg = [ - ((BCDTermUnit, BCDTermUnit) ** + ((BCDT_U, BCDT_U) ** []) - , ((BCDTermLeft, BCDTermLeft) ** + , ((BCDT_L, BCDT_L) ** [ (BCDTermL, BCDTermL) ]) - , ((BCDTermRight, BCDTermRight) ** + , ((BCDT_R, BCDT_R) ** [ (BCDTermR, BCDTermR) ]) - , ((BCDTermPair, BCDTermPair) ** + , ((BCDT_P, BCDT_P) ** [ (BCDTerm1, BCDTerm1), (BCDTerm2, BCDTerm2) ] ) ] @@ -348,13 +348,13 @@ public export BicartDistTermCheckAlg : PFProductBoolAlg BicartDistTermF BicartDistObjF BicartDistTermCheckAlg = [ - ((BCDTermUnit, BCDObjTerminal) ** + ((BCDT_U, BCDO_1) ** []) - , ((BCDTermLeft, BCDObjCoproduct) ** + , ((BCDT_L, BCDO_C) ** [(BCDTermL, BCDCopL)]) - , ((BCDTermRight, BCDObjCoproduct) ** + , ((BCDT_R, BCDO_C) ** [(BCDTermR, BCDCopR)]) - , ((BCDTermPair, BCDObjProduct) ** + , ((BCDT_P, BCDO_P) ** [ (BCDTerm1, BCDProd1), (BCDTerm2, BCDProd2) ] ) ] @@ -380,10 +380,10 @@ MkBicartDistTypedTerm t {checks} = MkRefinement {a=BicartDistTerm} t public export BCDTNumLeavesAlg : BicartDistTermAlg Nat -BCDTNumLeavesAlg BCDTermUnit d = 1 -BCDTNumLeavesAlg BCDTermLeft d = d BCDTermL -BCDTNumLeavesAlg BCDTermRight d = d BCDTermR -BCDTNumLeavesAlg BCDTermPair d = d BCDTerm1 + d BCDTerm2 +BCDTNumLeavesAlg BCDT_U d = 1 +BCDTNumLeavesAlg BCDT_L d = d BCDTermL +BCDTNumLeavesAlg BCDT_R d = d BCDTermR +BCDTNumLeavesAlg BCDT_P d = d BCDTerm1 + d BCDTerm2 public export bcdtNumLeaves : BicartDistTerm -> Nat @@ -391,10 +391,10 @@ bcdtNumLeaves = bicartDistTermCata BCDTNumLeavesAlg public export BCDTNumInternalNodesAlg : BicartDistTermAlg Nat -BCDTNumInternalNodesAlg BCDTermUnit d = 0 -BCDTNumInternalNodesAlg BCDTermLeft d = 1 + d BCDTermL -BCDTNumInternalNodesAlg BCDTermRight d = 1 + d BCDTermR -BCDTNumInternalNodesAlg BCDTermPair d = 1 + d BCDTerm1 + d BCDTerm2 +BCDTNumInternalNodesAlg BCDT_U d = 0 +BCDTNumInternalNodesAlg BCDT_L d = 1 + d BCDTermL +BCDTNumInternalNodesAlg BCDT_R d = 1 + d BCDTermR +BCDTNumInternalNodesAlg BCDT_P d = 1 + d BCDTerm1 + d BCDTerm2 public export bcdtNumInternalNodes : BicartDistTerm -> Nat @@ -402,10 +402,10 @@ bcdtNumInternalNodes = bicartDistTermCata BCDTNumInternalNodesAlg public export BCDTSizeAlg : BicartDistTermAlg Nat -BCDTSizeAlg BCDTermUnit d = 1 -BCDTSizeAlg BCDTermLeft d = 1 + d BCDTermL -BCDTSizeAlg BCDTermRight d = 1 + d BCDTermR -BCDTSizeAlg BCDTermPair d = 1 + d BCDTerm1 + d BCDTerm2 +BCDTSizeAlg BCDT_U d = 1 +BCDTSizeAlg BCDT_L d = 1 + d BCDTermL +BCDTSizeAlg BCDT_R d = 1 + d BCDTermR +BCDTSizeAlg BCDT_P d = 1 + d BCDTerm1 + d BCDTerm2 public export bcdtSize : BicartDistTerm -> Nat @@ -413,10 +413,10 @@ bcdtSize = bicartDistTermCata BCDTSizeAlg public export BCDTDepthAlg : BicartDistTermAlg Nat -BCDTDepthAlg BCDTermUnit d = 0 -BCDTDepthAlg BCDTermLeft d = 1 + d BCDTermL -BCDTDepthAlg BCDTermRight d = 1 + d BCDTermR -BCDTDepthAlg BCDTermPair d = 1 + maximum (d BCDTerm1) (d BCDTerm2) +BCDTDepthAlg BCDT_U d = 0 +BCDTDepthAlg BCDT_L d = 1 + d BCDTermL +BCDTDepthAlg BCDT_R d = 1 + d BCDTermR +BCDTDepthAlg BCDT_P d = 1 + maximum (d BCDTerm1) (d BCDTerm2) public export bcdtDepth : BicartDistTerm -> Nat @@ -499,8 +499,8 @@ data BicartDistReducedMorphPosBase : Type where public export BicartDistReducedMorphPosDep : SliceObj BicartDistReducedMorphPosBase BicartDistReducedMorphPosDep BCDRMorphPosMorph = BicartDistReducedMorphPos -BicartDistReducedMorphPosDep BCDRMorphPosObj = BicartDistObjPos -BicartDistReducedMorphPosDep BCDRMorphPosTerm = BicartDistTermPos +BicartDistReducedMorphPosDep BCDRMorphPosObj = BCDOPos +BicartDistReducedMorphPosDep BCDRMorphPosTerm = BCDTPos public export BicartDistReducedMorphDirDep : SliceObj (Sigma BicartDistReducedMorphPosDep) @@ -540,8 +540,8 @@ BicartDistUnrefinedReducedMorph = public export data PolyBCDPosPoly : Type where - PolyBCDPosPF : BicartDistObjPos -> PolyBCDPosPoly - PolyBCDPosSlice : BicartDistObjPos -> PolyBCDPosPoly + PolyBCDPosPF : BCDOPos -> PolyBCDPosPoly + PolyBCDPosSlice : BCDOPos -> PolyBCDPosPoly public export data PolyBCDPosBase : Type where @@ -550,7 +550,7 @@ data PolyBCDPosBase : Type where public export PolyBCDPosDep : SliceObj PolyBCDPosBase -PolyBCDPosDep PolyBCDSourceObj = BicartDistObjPos +PolyBCDPosDep PolyBCDSourceObj = BCDOPos PolyBCDPosDep PolyBCDPoly = PolyBCDPosPoly public export diff --git a/geb-idris/src/LanguageDef/RefinedADT.idr b/geb-idris/src/LanguageDef/RefinedADT.idr index b1b85ebba..a0c542a2f 100644 --- a/geb-idris/src/LanguageDef/RefinedADT.idr +++ b/geb-idris/src/LanguageDef/RefinedADT.idr @@ -898,8 +898,8 @@ MuS0EF = Mu Subst0EndoF public export pCataS0EF : ParamCata Subst0EndoF pCataS0EF v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ case com of + TFV var => subst var + TFC com => alg $ case com of Subst0EndoCovarRep f => Subst0EndoCovarRep $ pCataS0EF v a subst alg f Subst0EndoEmpty => Subst0EndoEmpty Subst0EndoSum f g => @@ -926,7 +926,7 @@ Show MuS0EF where -- The void-valued constant endofunctor -- the sum of no endofunctors. public export (!+) : FreeS0EF v -(!+) = inFreeComposite Subst0EndoEmpty +(!+) = inFC Subst0EndoEmpty -- The representable endofunctor represented by a given object -- in the -- endofunctor category, that is, by some endofunctor, which implicitly @@ -934,7 +934,7 @@ public export prefix 11 :>: public export (:>:) : FreeS0EF v -> FreeS0EF v -(:>:) a = inFreeComposite $ Subst0EndoCovarRep a +(:>:) a = inFC $ Subst0EndoCovarRep a -- The unit-valued constant endofunctor -- represented by the initial object -- (Void), and hence in the endofunctor category by the void-valued constant @@ -948,7 +948,7 @@ public export infixl 7 :+: public export (:+:) : FreeS0EF v -> FreeS0EF v -> FreeS0EF v -a :+: b = inFreeComposite $ Subst0EndoSum a b +a :+: b = inFC $ Subst0EndoSum a b ----------------------------------------------------------------------- ---- Interpretation of MuS0EF as monoid of polynomial endofunctors ---- @@ -1268,15 +1268,15 @@ RNatCoalg = Coalgebra RNatF public export TermRNat : Type -> Type -> Type -TermRNat = TermFunctor RNatF +TermRNat = TranslateFunctor RNatF public export TreeRNat : Type -> Type -> Type -TreeRNat = TreeFunctor RNatF +TreeRNat = ScaleFunctor RNatF public export LimitRNat : Type -> Type -LimitRNat = LimitIterF RNatF +LimitRNat = TrEitherF RNatF public export ColimitRNat : Type -> Type @@ -1284,19 +1284,19 @@ ColimitRNat = ColimitIterF RNatF public export TRNat0 : TermRNat v a -TRNat0 = TermComposite RNat0 +TRNat0 = TFC RNat0 public export TRNat1 : TermRNat v a -TRNat1 = TermComposite RNat1 +TRNat1 = TFC RNat1 public export TRNatSum : a -> a -> TermRNat v a -TRNatSum m n = TermComposite (RNatSum m n) +TRNatSum m n = TFC (RNatSum m n) public export TRNatProduct : a -> a -> TermRNat v a -TRNatProduct m n = TermComposite (RNatProduct m n) +TRNatProduct m n = TFC (RNatProduct m n) public export FreeRNatF : Type -> Type @@ -1317,8 +1317,8 @@ NuRNatF = Nu RNatF public export cataRNatF : ParamCata RNatF cataRNatF v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite n => alg $ case n of + TFV var => subst var + TFC n => alg $ case n of RNat0 => RNat0 RNat1 => RNat1 RNatSum m n => @@ -1373,8 +1373,8 @@ NuENatF = Nu ENatF public export cataENatF : ParamCata ENatF cataENatF v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite n => alg $ case n of + TFV var => subst var + TFC n => alg $ case n of ENatR n => ENatR $ case n of RNat0 => RNat0 RNat1 => RNat1 @@ -1977,11 +1977,11 @@ SExpCoalg = Coalgebra SExpBaseF public export SExpTermF : Type -> Type -> Type -SExpTermF = TermFunctor SExpBaseF +SExpTermF = TranslateFunctor SExpBaseF public export SExpTreeF : Type -> Type -> Type -SExpTreeF = TreeFunctor SExpBaseF +SExpTreeF = ScaleFunctor SExpBaseF public export SExpTermAlg : Type -> Type -> Type @@ -2005,11 +2005,11 @@ SPairF var carrier = ProductMonad (SExpTermF var carrier) public export SPairTermF : Type -> Type -> Type -SPairTermF var = TermFunctor (ProductMonad . SExpTermF var) var +SPairTermF var = TranslateFunctor (ProductMonad . SExpTermF var) var public export SPairTreeF : Type -> Type -> Type -SPairTreeF var = TreeFunctor (ProductMonad . SExpTermF var) var +SPairTreeF var = ScaleFunctor (ProductMonad . SExpTermF var) var --------------------- --------------------- diff --git a/geb-idris/src/LanguageDef/Syntax.idr b/geb-idris/src/LanguageDef/Syntax.idr index d38104cce..0cf36067b 100644 --- a/geb-idris/src/LanguageDef/Syntax.idr +++ b/geb-idris/src/LanguageDef/Syntax.idr @@ -80,6 +80,10 @@ public export data SExpF : Type -> Type -> Type where SXF : atom -> List Nat -> List xty -> SExpF atom xty +public export +Bifunctor SExpF where + bimap f g (SXF a ns xs) = SXF (f a) ns (map g xs) + public export sxfAtom : SExpF atom xty -> atom sxfAtom (SXF a _ _) = a @@ -92,26 +96,33 @@ public export sxfSubexprs : SExpF atom xty -> List xty sxfSubexprs (SXF _ _ xs) = xs +-- "Translate" the SExp functor, meaning, take its coproduct with a constant +-- type. +public export +data TrSExpF : Type -> Type -> Type -> Type where + TrV : v -> TrSExpF atom v a -- variable + TrC : SExpF atom a -> TrSExpF atom v a -- compound term + +public export +Bifunctor (TrSExpF atom) where + bimap f g (TrV v) = TrV (f v) + bimap f g (TrC c) = TrC (bimap id g c) + public export data FrSExpM : Type -> Type -> Type where - InSXV : ty -> FrSExpM atom ty -- variable - InSXC : SExpF atom (FrSExpM atom ty) -> FrSExpM atom ty -- compound term + InFS : TrSExpF atom ty (FrSExpM atom ty) -> FrSExpM atom ty public export SExp : Type -> Type SExp atom = FrSExpM atom Void public export -InSX : SExpF atom (SExp atom) -> SExp atom -InSX = InSXC - -public export -InS : atom -> List Nat -> List (SExp atom) -> SExp atom -InS a ns xs = InSX $ SXF a ns xs +InSX : SExpF atom (FrSExpM atom ty) -> FrSExpM atom ty +InSX = InFS . TrC public export -InSA : atom -> SExp atom -InSA a = InS a [] [] +InSV : ty -> FrSExpM atom ty +InSV = InFS . TrV public export FrSListM : Type -> Type -> Type @@ -122,17 +133,26 @@ SList : Type -> Type SList atom = FrSListM atom Void public export -InSF : atom -> List Nat -> FrSListM atom ty -> FrSExpM atom ty -InSF a ns xs = InSXC $ SXF a ns xs +InS : atom -> List Nat -> FrSListM atom ty -> FrSExpM atom ty +InS a ns xs = InSX $ SXF a ns xs + +public export +InSA : atom -> FrSExpM atom ty +InSA a = InS a [] [] +-- "Scale" the SExp functor, meaning, take its product with a constant +-- type. public export -InSFA : atom -> FrSExpM atom ty -InSFA a = InSF a [] [] +data ScSExpF : Type -> Type -> Type -> Type where + ScL : v -> SExpF atom a -> ScSExpF atom v a -- labeled term + +public export +Bifunctor (ScSExpF atom) where + bimap f g (ScL v c) = ScL (f v) (bimap id g c) public export data CoSExpCM : Type -> Type -> Type where - -- Labeled term - InSXL : ty -> SExpF atom (CoSExpCM atom ty) -> CoSExpCM atom ty + InSXL : ScSExpF atom ty (CoSExpCM atom ty) -> CoSExpCM atom ty public export record FrSXLAlg (atom, ty, a, b : Type) where @@ -162,8 +182,8 @@ SXLAlgToFr {atom} {a} {b} = SXLSubstAlgToFr (voidF a) mutual public export frsxCata : FrSXLAlg atom ty a b -> FrSExpM atom ty -> a - frsxCata alg (InSXV v) = alg.frsubst v - frsxCata alg (InSXC x) = case x of + frsxCata alg (InFS (TrV v)) = alg.frsubst v + frsxCata alg (InFS (TrC x)) = case x of SXF a ns xs => alg.frxalg a ns $ frslCata alg xs public export @@ -191,14 +211,14 @@ public export SExpAlg : Type -> Type -> Type SExpAlg atom a = SExpF atom a -> a -public export -SExpBoolAlg : Type -> Type -SExpBoolAlg atom = SExpAlg atom Bool - public export SExpTypeAlg : Type -> Type SExpTypeAlg atom = SExpAlg atom Type +public export +SExpTypeCtxAlg : Type -> Type -> Type +SExpTypeCtxAlg atom ctx = SExpAlg atom (ctx -> Type) + public export SExpConsAlg : SExpAlg atom a -> SXLAlg atom a (List a) SExpConsAlg alg = SXA (\x, ns, l => alg $ SXF x ns l) [] (::) @@ -225,13 +245,18 @@ slcPreservesLen : (alg : SExpAlg atom a) -> (l : SList atom) -> slcPreservesLen alg [] = Refl slcPreservesLen alg (x :: l) = cong S (slcPreservesLen alg l) +public export +frslcPreservesLen : (subst : ty -> a) -> (alg : SExpAlg atom a) -> + (l : FrSListM atom ty) -> length (frslistCata subst alg l) = length l +frslcPreservesLen subst alg [] = Refl +frslcPreservesLen subst alg (x :: l) = cong S (frslcPreservesLen subst alg l) + public export SExpMaybeAlg : Type -> Type -> Type SExpMaybeAlg atom a = SExpF atom a -> Maybe a public export -SExpAlgFromMaybe : - (SExpF atom a -> Maybe a) -> SXLAlg atom (Maybe a) (Maybe (List a)) +SExpAlgFromMaybe : SExpMaybeAlg atom a -> SXLAlg atom (Maybe a) (Maybe (List a)) SExpAlgFromMaybe alg = SXA (\x, ns, ml => case ml of @@ -260,6 +285,430 @@ frslistMaybeCata : (ty -> Maybe a) -> SExpMaybeAlg atom a -> FrSListM atom ty -> Maybe (List a) frslistMaybeCata subst = slSubstCata subst . SExpAlgFromMaybe +public export +SExpMaybeCtxAlg : Type -> Type -> Type -> Type +SExpMaybeCtxAlg atom ctx a = SExpF atom a -> ctx -> Maybe a + +public export +SExpCtxAlgFromMaybe : SExpMaybeCtxAlg atom ctx a -> + SXLAlg atom (ctx -> Maybe a) (ctx -> Maybe (List a)) +SExpCtxAlgFromMaybe alg = + SXA + (\x, ns, ml, ctx => case ml ctx of + Just l => alg (SXF x ns l) ctx + Nothing => Nothing) + (const $ Just []) + (\mx, ml, ctx => case (mx ctx, ml ctx) of + (Just x, Just l) => Just (x :: l) + _ => Nothing) + +public export +sexpMaybeCtxCata : SExpMaybeCtxAlg atom ctx a -> SExp atom -> ctx -> Maybe a +sexpMaybeCtxCata = sxCata . SExpCtxAlgFromMaybe + +public export +frsexpMaybeCtxCata : (ty -> ctx -> Maybe a) -> SExpMaybeCtxAlg atom ctx a -> + FrSExpM atom ty -> ctx -> Maybe a +frsexpMaybeCtxCata subst = sxSubstCata subst . SExpCtxAlgFromMaybe + +public export +slistMaybeCtxCata : SExpMaybeCtxAlg atom ctx a -> + SList atom -> ctx -> Maybe (List a) +slistMaybeCtxCata = slCata . SExpCtxAlgFromMaybe + +public export +frslistMaybeCtxCata : (ty -> ctx -> Maybe a) -> SExpMaybeCtxAlg atom ctx a -> + FrSListM atom ty -> ctx -> Maybe (List a) +frslistMaybeCtxCata subst = slSubstCata subst . SExpCtxAlgFromMaybe + +public export +SExpBoolAlg : Type -> Type +SExpBoolAlg atom = atom -> List Nat -> Maybe Nat + +public export +SExpAlgFromBool : SExpBoolAlg atom -> SExpAlg atom Bool +SExpAlgFromBool alg (SXF a ns xs) = all id xs && alg a ns == Just (length xs) + +public export +SExpBoolToMaybeAlg : SExpBoolAlg atom -> SExpMaybeAlg atom Unit +SExpBoolToMaybeAlg alg (SXF a ns xs) = + if (alg a ns == Just (length xs)) then Just () else Nothing + +public export +sexpBoolCata : SExpBoolAlg atom -> SExp atom -> Bool +sexpBoolCata = sexpCata . SExpAlgFromBool + +public export +frsexpBoolCata : + (ty -> Bool) -> SExpBoolAlg atom -> FrSExpM atom ty -> Bool +frsexpBoolCata subst = frsexpCata subst . SExpAlgFromBool + +public export +slistBoolCataL : SExpBoolAlg atom -> SList atom -> List Bool +slistBoolCataL = slistCata . SExpAlgFromBool + +public export +slistBoolCata : SExpBoolAlg atom -> SList atom -> Bool +slistBoolCata alg l = all id (slistBoolCataL alg l) + +public export +frslistBoolCataL : + (ty -> Bool) -> SExpBoolAlg atom -> FrSListM atom ty -> List Bool +frslistBoolCataL subst = frslistCata subst . SExpAlgFromBool + +public export +frslistBoolCata : + (ty -> Bool) -> SExpBoolAlg atom -> FrSListM atom ty -> Bool +frslistBoolCata subst alg l = all id (frslistBoolCataL subst alg l) + +public export +SExpRefined : {atom : Type} -> SExpBoolAlg atom -> Type +SExpRefined alg = Refinement {a=(SExp atom)} (sexpBoolCata alg) + +public export +SExpRefinedUnicity : {atom : Type} -> {alg : SExpBoolAlg atom} -> + {x, x' : SExpRefined alg} -> + shape {p=(sexpBoolCata alg)} x = shape {p=(sexpBoolCata alg)} x' -> x = x' +SExpRefinedUnicity {atom} {alg} = + refinementFstEq {a=(SExp atom)} {pred=(sexpBoolCata alg)} + +public export +ProdT : List Type -> Type +ProdT = foldr Pair Unit + +public export +SExpForallAlg : SExpTypeAlg atom -> SExpTypeAlg atom +SExpForallAlg alg x = (alg x, ProdT (sxfSubexprs x)) + +public export +sexpForallCata : SExpTypeAlg atom -> SExp atom -> Type +sexpForallCata = sexpCata . SExpForallAlg + +public export +slistForallCataL : SExpTypeAlg atom -> SList atom -> List Type +slistForallCataL = slistCata . SExpForallAlg + +public export +slistForallCata : SExpTypeAlg atom -> SList atom -> Type +slistForallCata = ProdT .* slistForallCataL + +public export +SExpTypeAlgFromBool : SExpBoolAlg atom -> SExpTypeAlg atom +SExpTypeAlgFromBool alg (SXF a ns tys) = alg a ns = Just (length tys) + +public export +sexpBoolTypeCata : SExpBoolAlg atom -> SExp atom -> Type +sexpBoolTypeCata = sexpForallCata . SExpTypeAlgFromBool + +public export +slistBoolTypeCataL : SExpBoolAlg atom -> SList atom -> List Type +slistBoolTypeCataL = slistForallCataL . SExpTypeAlgFromBool + +public export +slistBoolTypeCata : SExpBoolAlg atom -> SList atom -> Type +slistBoolTypeCata = slistForallCata . SExpTypeAlgFromBool + +public export +SExpConstrained : {atom : Type} -> SExpBoolAlg atom -> Type +SExpConstrained alg = Subset0 (SExp atom) (sexpBoolTypeCata alg) + +mutual + public export + sexpBoolTypeCata_unique : {alg : SExpBoolAlg atom} -> {x : SExp atom} -> + (w, w' : sexpBoolTypeCata alg x) -> w = w' + sexpBoolTypeCata_unique {x=(InFS (TrV v))} w w' = void v + sexpBoolTypeCata_unique {alg} {x=(InFS (TrC (SXF a ns xs)))} + (algeq, subeq) (algeq', subeq') = + rewrite uip {eq=algeq} {eq'=algeq'} in + rewrite slistBoolTypeCata_unique {alg} {l=xs} subeq subeq' in + Refl + + public export + slistBoolTypeCata_unique : {alg : SExpBoolAlg atom} -> {l : SList atom} -> + (w, w' : slistBoolTypeCata alg l) -> w = w' + slistBoolTypeCata_unique {l=[]} () () = Refl + slistBoolTypeCata_unique {alg} {l=(x :: xs)} (wx, wxs) (wx', wxs') = + rewrite sexpBoolTypeCata_unique {alg} {x} wx wx' in + rewrite slistBoolTypeCata_unique {alg} {l=xs} wxs wxs' in + Refl + +public export +SExpConstrainedUnicity : {atom : Type} -> {alg : SExpBoolAlg atom} -> + {x, x' : SExpConstrained alg} -> + fst0 x = fst0 x' -> x = x' +SExpConstrainedUnicity {alg} {x=(Element0 x p)} {x'=(Element0 _ p')} Refl = + replace + {p=(\p'' => Element0 x p = Element0 {dep=(sexpBoolTypeCata alg)} x p'')} + (sexpBoolTypeCata_unique {alg} p p') + Refl + +mutual + public export + sexpBoolComputeToConstraint : (alg : SExpBoolAlg atom) -> (x : SExp atom) -> + sexpBoolCata alg x = True -> sexpBoolTypeCata alg x + sexpBoolComputeToConstraint alg (InFS (TrV v)) eq = void v + sexpBoolComputeToConstraint alg (InFS (TrC (SXF a ns xs))) eq = + (rewrite slcPreservesLen (SExpForallAlg (SExpTypeAlgFromBool alg)) xs in + rewrite sym (slcPreservesLen (SExpAlgFromBool alg) xs) in + fromIsTrueMaybeNat _ _ (andRight eq), + slistBoolComputeToConstraint alg xs $ andLeft eq) + + public export + slistBoolComputeToConstraint : (alg : SExpBoolAlg atom) -> (l : SList atom) -> + slistBoolCata alg l = True -> slistBoolTypeCata alg l + slistBoolComputeToConstraint alg [] eq = () + slistBoolComputeToConstraint alg (x :: xs) eq = + (sexpBoolComputeToConstraint alg x $ foldTrueInit _ _ eq, + slistBoolComputeToConstraint alg xs $ foldTrueList _ _ eq) + +mutual + public export + sexpBoolConstraintToCompute : (alg : SExpBoolAlg atom) -> (x : SExp atom) -> + sexpBoolTypeCata alg x -> sexpBoolCata alg x = True + sexpBoolConstraintToCompute alg (InFS (TrV v)) w = void v + sexpBoolConstraintToCompute alg (InFS (TrC (SXF a ns xs))) (algeq, subeq) = + andBoth + (slistBoolConstraintToCompute alg xs subeq) + (toIsTrueMaybeNat _ _ $ + replace {p=(\len => alg a ns = Just len)} + (sym (slcPreservesLen (SExpAlgFromBool alg) xs)) + (replace {p=(\len => alg a ns = Just len)} + (slcPreservesLen (SExpForallAlg (SExpTypeAlgFromBool alg)) xs) + algeq)) + + public export + slistBoolConstraintToCompute : (alg : SExpBoolAlg atom) -> (l : SList atom) -> + slistBoolTypeCata alg l -> slistBoolCata alg l = True + slistBoolConstraintToCompute alg [] () = Refl + slistBoolConstraintToCompute alg (x :: xs) (xeq, xseq) = + foldTrueBoth (sexpBoolCata alg x) (slistBoolCataL alg xs) + (sexpBoolConstraintToCompute alg x xeq) + (slistBoolConstraintToCompute alg xs xseq) + +public export +sexpCtoR : {atom : Type} -> {alg : SExpBoolAlg atom} -> + SExpConstrained alg -> SExpRefined alg +sexpCtoR (Element0 x p) = (Element0 x $ sexpBoolConstraintToCompute alg x p) + +public export +sexpRtoC : {atom : Type} -> {alg : SExpBoolAlg atom} -> + SExpRefined alg -> SExpConstrained alg +sexpRtoC (Element0 x p) = (Element0 x $ sexpBoolComputeToConstraint alg x p) + +public export +sexpCtoRtoCid : {atom : Type} -> {alg : SExpBoolAlg atom} -> + (x : SExpConstrained alg) -> sexpRtoC {alg} (sexpCtoR {alg} x) = x +sexpCtoRtoCid {alg} (Element0 x p) = SExpConstrainedUnicity {alg} Refl + +public export +sexpRtoCtoRid : {atom : Type} -> {alg : SExpBoolAlg atom} -> + (x : SExpRefined alg) -> sexpCtoR {alg} (sexpRtoC {alg} x) = x +sexpRtoCtoRid {alg} (Element0 x p) = SExpRefinedUnicity {alg} Refl + +--------------------------------------- +---- Context-dependent refinements ---- +--------------------------------------- + +public export +SExpBoolCtxAlg : Type -> Type -> Type +SExpBoolCtxAlg atom ctx = atom -> List Nat -> ctx -> Maybe (List ctx) + +public export +SExpAlgFromBoolCtx : SExpBoolCtxAlg atom ctx -> SExpAlg atom (ctx -> Bool) +SExpAlgFromBoolCtx alg (SXF a ns xs) c with (alg a ns c) + SExpAlgFromBoolCtx alg (SXF a ns xs) c | Just cs = + case decEq (length xs) (length cs) of + Yes eq => all id $ zipLen id xs cs eq + No neq => False + SExpAlgFromBoolCtx alg (SXF a ns xs) c | Nothing = False + +public export +sexpBoolCtxCata : SExpBoolCtxAlg atom ctx -> SExp atom -> ctx -> Bool +sexpBoolCtxCata = sexpCata . SExpAlgFromBoolCtx + +public export +sexpBoolCtxCataFlip : SExpBoolCtxAlg atom ctx -> ctx -> SExp atom -> Bool +sexpBoolCtxCataFlip = flip . sexpBoolCtxCata + +public export +frsexpBoolCtxCata : (ty -> ctx -> Bool) -> + SExpBoolCtxAlg atom ctx -> FrSExpM atom ty -> ctx -> Bool +frsexpBoolCtxCata subst = frsexpCata subst . SExpAlgFromBoolCtx + +public export +slistBoolCtxCataL : SExpBoolCtxAlg atom ctx -> SList atom -> List (ctx -> Bool) +slistBoolCtxCataL = slistCata . SExpAlgFromBoolCtx + +public export +slistBoolCtxCata : SExpBoolCtxAlg atom ctx -> SList atom -> ctx -> Bool +slistBoolCtxCata alg l c = all id $ map (\f => f c) $ slistBoolCtxCataL alg l + +public export +frslistBoolCtxCataL : (ty -> ctx -> Bool) -> SExpBoolCtxAlg atom ctx -> + FrSListM atom ty -> List (ctx -> Bool) +frslistBoolCtxCataL subst = frslistCata subst . SExpAlgFromBoolCtx + +public export +frslistBoolCtxCata : (ty -> ctx -> Bool) -> SExpBoolCtxAlg atom ctx -> + FrSListM atom ty -> ctx -> Bool +frslistBoolCtxCata subst alg l c = + all id $ map (\f => f c) $ frslistBoolCtxCataL subst alg l + +public export +SExpCtxRefined : {atom, ctx : Type} -> SExpBoolCtxAlg atom ctx -> SliceObj ctx +SExpCtxRefined {atom} {ctx} alg c = + Refinement {a=(SExp atom)} (sexpBoolCtxCataFlip alg c) + +public export +SExpCtxRefinedUnicity : {atom, ctx : Type} -> {alg : SExpBoolCtxAlg atom ctx} -> + {c : ctx} -> {x, x' : SExpCtxRefined alg c} -> + shape {p=(sexpBoolCtxCataFlip alg c)} x = + shape {p=(sexpBoolCtxCataFlip alg c)} x' -> + x = x' +SExpCtxRefinedUnicity {atom} {ctx} {alg} {c} {x} {x'} = + refinementFstEq {a=(SExp atom)} {pred=(sexpBoolCtxCataFlip alg c)} + +public export +SExpForallConstCtxAlg : SExpTypeCtxAlg atom ctx -> SExpTypeCtxAlg atom ctx +SExpForallConstCtxAlg alg x c = + (alg x c, ProdT $ map (\f => f c) $ sxfSubexprs x) + +public export +sexpForallConstCtxCata : SExpTypeCtxAlg atom ctx -> SExp atom -> ctx -> Type +sexpForallConstCtxCata = sexpCata . SExpForallConstCtxAlg + +public export +slistForallConstCtxCataL : + SExpTypeCtxAlg atom ctx -> SList atom -> ctx -> List Type +slistForallConstCtxCataL alg l c = + map (\f => f c) $ slistCata (SExpForallConstCtxAlg alg) l + +public export +slistForallConstCtxCata : SExpTypeCtxAlg atom ctx -> SList atom -> ctx -> Type +slistForallConstCtxCata alg = ProdT .* slistForallConstCtxCataL alg + +public export +SExpTypeForallCtxAlgFromBool : {ctx : Type} -> + SExpBoolCtxAlg atom ctx -> SExpTypeCtxAlg atom ctx +SExpTypeForallCtxAlgFromBool {ctx} alg (SXF a ns tys) c = + (j : IsJustTrue (alg a ns c) ** + eq : Prelude.List.length tys = Prelude.List.length (fromIsJust j) ** + ProdT $ zipLen id tys (fromIsJust j) eq) + +public export +sexpBoolTypeCtxCata : {ctx : Type} -> SExpBoolCtxAlg atom ctx -> + SExp atom -> ctx -> Type +sexpBoolTypeCtxCata = sexpCata . SExpTypeForallCtxAlgFromBool + +public export +sexpBoolTypeCtxCataFlip : {ctx : Type} -> SExpBoolCtxAlg atom ctx -> + ctx -> SExp atom -> Type +sexpBoolTypeCtxCataFlip = flip . sexpBoolTypeCtxCata + +public export +slistBoolTypeCtxCataL : {ctx : Type} -> SExpBoolCtxAlg atom ctx -> + SList atom -> List (ctx -> Type) +slistBoolTypeCtxCataL = slistCata . SExpTypeForallCtxAlgFromBool + +public export +slistBoolTypeCtxCata : {ctx : Type} -> SExpBoolCtxAlg atom ctx -> + SList atom -> ctx -> Type +slistBoolTypeCtxCata alg l c = + ProdT $ map (\f => f c) $ slistBoolTypeCtxCataL alg l + +public export +SExpCtxConstrained : {atom, ctx : Type} -> + SExpBoolCtxAlg atom ctx -> SliceObj ctx +SExpCtxConstrained {atom} {ctx} alg c = + Subset0 (SExp atom) (sexpBoolTypeCtxCataFlip alg c) + +------------------------------- +---- Slice (cata)morphisms ---- +------------------------------- + +public export +record SExpSliceAlg {ty : Type} + (sxa : SliceObj (FrSExpM atom ty)) (sxb : SliceObj (FrSExpM atom ty)) + (sla : SliceObj (FrSListM atom ty)) (slb : SliceObj (FrSListM atom ty)) + where + constructor SSA + ssaSubTy : + (a : atom) -> (ns : List Nat) -> (xs : FrSListM atom ty) -> + sxa (InFS (TrC (SXF a ns xs))) -> sla xs + ssaHeadTy : + (x : FrSExpM atom ty) -> (xs : FrSListM atom ty) -> sla (x :: xs) -> sxa x + ssaTailTy : + (x : FrSExpM atom ty) -> (xs : FrSListM atom ty) -> sla (x :: xs) -> sla xs + ssaSubst : SliceMorphism {a=ty} (sxa . InSV) (sxb . InSV) + ssaInd : + (a : atom) -> (ns : List Nat) -> (xs : FrSListM atom ty) -> + sxa (InFS (TrC (SXF a ns xs))) -> slb xs -> sxb (InFS (TrC (SXF a ns xs))) + ssaNil : sla [] -> slb [] + ssaCons : + (x : FrSExpM atom ty) -> (xs : FrSListM atom ty) -> + sxb x -> slb xs -> slb (x :: xs) + +mutual + public export + sexpDepCata : + {sxa, sxb : SliceObj (FrSExpM atom ty)} -> + {sla, slb : SliceObj (FrSListM atom ty)} -> + (alg : SExpSliceAlg sxa sxb sla slb) -> + SliceMorphism {a=(FrSExpM atom ty)} sxa sxb + sexpDepCata alg (InFS (TrV v)) av = alg.ssaSubst v av + sexpDepCata alg (InFS (TrC (SXF a ns xs))) ax = + alg.ssaInd a ns xs ax (slistDepCata alg xs (alg.ssaSubTy a ns xs ax)) + + public export + slistDepCata : + {sxa, sxb : SliceObj (FrSExpM atom ty)} -> + {sla, slb : SliceObj (FrSListM atom ty)} -> + (alg : SExpSliceAlg sxa sxb sla slb) -> + SliceMorphism {a=(FrSListM atom ty)} sla slb + slistDepCata alg [] al = alg.ssaNil al + slistDepCata alg (x :: xs) al = + alg.ssaCons x xs + (sexpDepCata alg x (alg.ssaHeadTy x xs al)) + (slistDepCata alg xs (alg.ssaTailTy x xs al)) + +public export +SExpSliceMorphAlg : {atom : Type} -> + SExpTypeAlg atom -> SExpTypeAlg atom -> Type +SExpSliceMorphAlg {atom} sa sb = + (a : atom) -> (ns : List Nat) -> (xs : SList atom) -> + sa (SXF a ns $ slistForallCataL sa xs) -> + slistForallCata sa xs -> + slistForallCata sb xs -> + sb (SXF a ns $ slistForallCataL sb xs) + +public export +SExpSliceAlgFromMorph : {sa, sb : SExpTypeAlg atom} -> + SExpSliceMorphAlg sa sb -> + SExpSliceAlg + (sexpForallCata sa) (sexpForallCata sb) + (slistForallCata sa) (slistForallCata sb) +SExpSliceAlgFromMorph alg = + SSA + (\a, ns, xs, (sxa, subs) => subs) + (\x, xs, (sx, sxs) => sx) + (\x, xs, (sx, sxs) => sxs) + (\v, _ => void v) + (\a, ns, xs, (sx, sxas), sxbs => (alg a ns xs sx sxas sxbs, sxbs)) + id + (\x, xs, sx, sxs => (sx, sxs)) + +public export +sexpSliceCata : {sa, sb : SExpTypeAlg atom} -> + SExpSliceMorphAlg sa sb -> + SliceMorphism {a=(SExp atom)} (sexpForallCata sa) (sexpForallCata sb) +sexpSliceCata {sa} {sb} = sexpDepCata . (SExpSliceAlgFromMorph {sa} {sb}) + +public export +slistSliceCata : {sa, sb : SExpTypeAlg atom} -> + SExpSliceMorphAlg sa sb -> + SliceMorphism {a=(SList atom)} (slistForallCata sa) (slistForallCata sb) +slistSliceCata {sa} {sb} = slistDepCata . (SExpSliceAlgFromMorph {sa} {sb}) + ------------------- ---- Utilities ---- ------------------- @@ -386,20 +835,23 @@ mutual public export sexpDecEq : {atom : Type} -> DecEq ty => DecEqPred atom -> DecEqPred (FrSExpM atom ty) - sexpDecEq deq (InSXV v) (InSXV v') = + sexpDecEq deq (InFS (TrV v)) (InFS (TrV v')) = case decEq v v' of Yes Refl => Yes Refl No neq => No $ \Refl => neq Refl - sexpDecEq deq (InSXV _) (InSXC _) = No $ \eq => case eq of Refl impossible - sexpDecEq deq (InSXC _) (InSXV _) = No $ \eq => case eq of Refl impossible - sexpDecEq deq (InSXC (SXF a ns xs)) (InSXC (SXF a' ns' xs')) = - case deq a a' of - Yes Refl => case decEq ns ns' of - Yes Refl => case slistDecEq deq xs xs' of - Yes Refl => Yes Refl + sexpDecEq deq (InFS (TrV _)) (InFS (TrC _)) = + No $ \eq => case eq of Refl impossible + sexpDecEq deq (InFS (TrC _)) (InFS (TrV _)) = + No $ \eq => case eq of Refl impossible + sexpDecEq deq (InFS (TrC (SXF a ns xs))) (InFS (TrC c')) = + case c' of + SXF a' ns' xs' => case deq a a' of + Yes Refl => case decEq ns ns' of + Yes Refl => case slistDecEq deq xs xs' of + Yes Refl => Yes Refl + No neq => No $ \eq => case eq of Refl => neq Refl No neq => No $ \eq => case eq of Refl => neq Refl No neq => No $ \eq => case eq of Refl => neq Refl - No neq => No $ \eq => case eq of Refl => neq Refl public export slistDecEq : {atom : Type} -> DecEq ty => @@ -422,9 +874,31 @@ public export (atom : Type) => DecEq atom => DecEq ty => Eq (FrSExpM atom ty) where x == x' = isYes $ decEq x x' --------------------------- ----- Monad operations ---- --------------------------- +public export +(atom : Type) => DecEq atom => (alg : SExpBoolAlg atom) => + DecEq (SExpRefined alg) where + decEq (Element0 x p) (Element0 x' p') = case decEq x x' of + Yes eq => Yes $ SExpRefinedUnicity {alg} eq + No neq => No $ \Refl => neq Refl + +public export +(atom : Type) => DecEq atom => (alg : SExpBoolAlg atom) => + DecEq (SExpConstrained alg) where + decEq (Element0 x p) (Element0 x' p') = case decEq x x' of + Yes eq => Yes $ SExpConstrainedUnicity {alg} eq + No neq => No $ \Refl => neq Refl + +--------------------------------------------------------------------- +---- SExp monad operations (where the domain is a type of atoms) ---- +--------------------------------------------------------------------- + +public export +sexpMapAlg : (atom -> atom') -> SExpAlg atom (FrSExpM atom' ty) +sexpMapAlg f (SXF a ns xs) = InS (f a) ns xs + +public export +Functor SExp where + map = sexpCata . sexpMapAlg public export sexpReturn : atom -> SExp atom @@ -432,37 +906,79 @@ sexpReturn a = InS a [] [] public export SExpJoinAlg : SExpAlg (SExp atom) (SExp atom) -SExpJoinAlg (SXF (InSXC (SXF a ns xs)) ns' xs') = InS a (ns ++ ns') (xs ++ xs') +SExpJoinAlg (SXF (InFS (TrV v)) ns' xs') = void v +SExpJoinAlg (SXF (InFS (TrC (SXF a ns xs))) ns' xs') = + InS a (ns ++ ns') (xs ++ xs') public export sexpJoin : SExp (SExp atom) -> SExp atom sexpJoin = sexpCata SExpJoinAlg -------------------------------- -------------------------------- ----- Refined s-expressions ---- -------------------------------- -------------------------------- +public export +sexpBind : SExp atom -> (atom -> SExp atom') -> SExp atom' +sexpBind x f = sexpJoin (map {f=SExp} f x) ---------------------------------------------- ----- General induction for s-expressions ---- ---------------------------------------------- +public export +sexpApp : SExp (a -> b) -> SExp a -> SExp b +sexpApp xf = sexpBind xf . flip (map {f=SExp}) + +public export +Applicative SExp where + pure = sexpReturn + (<*>) = sexpApp + +public export +Monad SExp where + (>>=) = sexpBind + join = sexpJoin + +---------------------------------------------------------------------------- +---- FrSExpM monad operations (where the domain is a type of variables) ---- +---------------------------------------------------------------------------- + +public export +Bifunctor FrSExpM where + bimap f g = frsexpCata (InSV . g) (sexpMapAlg f) public export -SExpGenBoolAlg : SExpBoolAlg atom -> SExpBoolAlg atom -SExpGenBoolAlg alg x = all id (sxfSubexprs x) && alg x +frsexpReturn : ty -> FrSExpM atom ty +frsexpReturn = InSV public export -sexpGenBoolCata : SExpBoolAlg atom -> SExp atom -> Bool -sexpGenBoolCata = sexpCata . SExpGenBoolAlg +frsexpJoinAlg : SExpAlg atom (FrSExpM atom ty) +frsexpJoinAlg = InSX public export -slistGenBoolCataL : SExpBoolAlg atom -> SList atom -> List Bool -slistGenBoolCataL = slistCata . SExpGenBoolAlg +frsexpJoin : FrSExpM atom (FrSExpM atom ty) -> FrSExpM atom ty +frsexpJoin = frsexpCata id frsexpJoinAlg public export -slistGenBoolCata : SExpBoolAlg atom -> SList atom -> Bool -slistGenBoolCata alg l = all id (slistGenBoolCataL alg l) +frsexpBind : FrSExpM atom a -> (a -> FrSExpM atom b) -> FrSExpM atom b +frsexpBind x f = frsexpJoin (map {f=(FrSExpM atom)} f x) + +public export +frsexpApp : FrSExpM atom (a -> b) -> FrSExpM atom a -> FrSExpM atom b +frsexpApp xf = frsexpBind xf . flip (map {f=(FrSExpM atom)}) + +public export +Applicative (FrSExpM atom) where + pure = frsexpReturn + (<*>) = frsexpApp + +public export +Monad (FrSExpM atom) where + (>>=) = frsexpBind + join = frsexpJoin + +------------------------------- +------------------------------- +---- Refined s-expressions ---- +------------------------------- +------------------------------- + +--------------------------------------------- +---- General induction for s-expressions ---- +--------------------------------------------- public export SExpGenTypeAlg : SExpTypeAlg atom -> SExpTypeAlg atom @@ -498,14 +1014,14 @@ mutual (step : SExpDepAlg alg paramAlg) -> (x : SExp atom) -> Maybe (sexpGenTypeCata alg x) - sexpGenTypeDec alg paramAlg step (InSXC (SXF a ns xs)) with + sexpGenTypeDec alg paramAlg step (InFS (TrC (SXF a ns xs))) with (slistGenTypeDec alg paramAlg step xs, slistMaybeCata paramAlg xs) proof prf - sexpGenTypeDec alg paramAlg step (InSXC (SXF a ns xs)) + sexpGenTypeDec alg paramAlg step (InFS (TrC (SXF a ns xs))) | (Just vxs, Just params) = case step a ns xs vxs params (sndEq prf) of Just ty => Just (vxs, ty) _ => Nothing - sexpGenTypeDec alg paramAlg step (InSXC (SXF a ns xs)) + sexpGenTypeDec alg paramAlg step (InFS (TrC (SXF a ns xs))) | _ = Nothing public export @@ -560,16 +1076,12 @@ record SArity (atom : Type) where public export CheckSExpLenAlg : SArity atom -> SExpBoolAlg atom -CheckSExpLenAlg ar (SXF a ns xs) = - listBounded ns (ar.natBounds a) && length xs == ar.expAr a - -public export -CheckSExpArAlg: SArity atom -> SExpBoolAlg atom -CheckSExpArAlg = SExpGenBoolAlg . CheckSExpLenAlg +CheckSExpLenAlg ar a ns = + if listBounded ns (ar.natBounds a) then Just (ar.expAr a) else Nothing public export checkSExpAr : SArity atom -> SExp atom -> Bool -checkSExpAr = sexpGenBoolCata . CheckSExpLenAlg +checkSExpAr = sexpBoolCata . CheckSExpLenAlg public export ValidSExpLenAlg : SArity atom -> SExpTypeAlg atom @@ -774,3 +1286,19 @@ GBtAtom = SExpToBtAtom GebAtom public export GBTExp : Type GBTExp = BTExp GBtAtom + +public export +GExpAlg : Type -> Type +GExpAlg = SExpAlg GebAtom + +public export +GExpMaybeAlg : Type -> Type +GExpMaybeAlg = SExpMaybeAlg GebAtom + +public export +GExpBoolAlg : Type +GExpBoolAlg = SExpBoolAlg GebAtom + +public export +GExpMaybeCtxAlg : Type -> Type -> Type +GExpMaybeCtxAlg = SExpMaybeCtxAlg GebAtom diff --git a/geb-idris/src/LanguageDef/Test/AdjunctionsTest.idr b/geb-idris/src/LanguageDef/Test/AdjunctionsTest.idr new file mode 100644 index 000000000..38398fda1 --- /dev/null +++ b/geb-idris/src/LanguageDef/Test/AdjunctionsTest.idr @@ -0,0 +1,26 @@ +module LanguageDef.Test.AdjunctionsTest + +import Test.TestLibrary +import LanguageDef.Test.ProgFinSetTest +import LanguageDef.Adjunctions + +%default total + +---------------------------------- +---------------------------------- +----- Exported test function ----- +---------------------------------- +---------------------------------- + +export +adjunctionsTest : IO () +adjunctionsTest = do + putStrLn "" + putStrLn "======================" + putStrLn "Begin AdjunctionsTest:" + putStrLn "----------------------" + putStrLn "" + putStrLn "--------------------" + putStrLn "End AdjunctionsTest." + putStrLn "====================" + pure () diff --git a/geb-idris/src/LanguageDef/Test/DiagramCatTest.idr b/geb-idris/src/LanguageDef/Test/DiagramCatTest.idr new file mode 100644 index 000000000..7273dfc2c --- /dev/null +++ b/geb-idris/src/LanguageDef/Test/DiagramCatTest.idr @@ -0,0 +1,26 @@ +module LanguageDef.Test.DiagramCatTest + +import Test.TestLibrary +import LanguageDef.Test.ProgFinSetTest +import LanguageDef.DiagramCat + +%default total + +---------------------------------- +---------------------------------- +----- Exported test function ----- +---------------------------------- +---------------------------------- + +export +diagramCatTest : IO () +diagramCatTest = do + putStrLn "" + putStrLn "=====================" + putStrLn "Begin DiagramCatTest:" + putStrLn "---------------------" + putStrLn "" + putStrLn "--------------------" + putStrLn "End DiagramCatTest." + putStrLn "====================" + pure () diff --git a/geb-idris/src/LanguageDef/Test/GebToposTest.idr b/geb-idris/src/LanguageDef/Test/GebToposTest.idr index aed2e6ef3..7de606e34 100644 --- a/geb-idris/src/LanguageDef/Test/GebToposTest.idr +++ b/geb-idris/src/LanguageDef/Test/GebToposTest.idr @@ -42,6 +42,210 @@ objcL = Ctor 0 [] 0 [] objcP : Constructor TFsz objcP = Ctor 0 [] 0 [] +----------------------------- +----------------------------- +---- Simple s-expression ---- +----------------------------- +----------------------------- + +ox1 : OExp +ox1 = InS BCDO_0 [] [] + +ox1_fbt : Assertion +ox1_fbt = Assert $ checkAsBCDO ox1 + +ox1' : OExp +ox1' = InS BCDO_0 [0] [] + +ox1'_nfbt : Assertion +ox1'_nfbt = Assert $ not $ checkAsBCDO ox1' + +ox1'' : OExp +ox1'' = InS BCDO_0 [] [InS BCDO_0 [] []] + +ox1''_nfbt : Assertion +ox1''_nfbt = Assert $ not $ checkAsBCDO ox1'' + +ox2 : OExp +ox2 = InS BCDO_1 [] [] + +ox2_fbt : Assertion +ox2_fbt = Assert $ checkAsBCDO ox2 + +ox3 : OExp +ox3 = InS BCDO_C [] [ox1, ox2] + +ox3_fbt : Assertion +ox3_fbt = Assert $ checkAsBCDO ox3 + +ox3' : OExp +ox3' = InS BCDO_C [] [ox1] + +ox3'_nfbt : Assertion +ox3'_nfbt = Assert $ not $ checkAsBCDO ox3' + +ox3'' : OExp +ox3'' = InS BCDO_C [0, 1] [ox1, ox2] + +ox3''_nfbt : Assertion +ox3''_nfbt = Assert $ not $ checkAsBCDO ox3'' + +ox4 : OExp +ox4 = InS BCDO_P [] [ox1, ox2] + +ox4_fbt : Assertion +ox4_fbt = Assert $ checkAsBCDO ox4 + +ox5 : OExp +ox5 = InS BCDO_P [] [ox3, ox4] + +ox5_fbt : Assertion +ox5_fbt = Assert $ checkAsBCDO ox5 + +ox5' : OExp +ox5' = InS BCDO_P [] [] + +ox5'_fbt : Assertion +ox5'_fbt = Assert $ not $ checkAsBCDO ox5' + +ox5'' : OExp +ox5'' = InS BCDO_P [] [ox3', ox4] + +ox5''_fbt : Assertion +ox5''_fbt = Assert $ not $ checkAsBCDO ox5'' + +tx6 : TExp +tx6 = InS BCDT_U [] [] + +tx6_ft : Assertion +tx6_ft = Assert $ checkAsBCDT tx6 + +tx7 : TExp +tx7 = InS BCDT_L [] [tx6] + +tx7_ft : Assertion +tx7_ft = Assert $ checkAsBCDT tx7 + +tx8 : TExp +tx8 = InS BCDT_R [] [tx6] + +tx8_ft : Assertion +tx8_ft = Assert $ checkAsBCDT tx8 + +tx9 : TExp +tx9 = InS BCDT_P [] [tx7, tx8] + +tx9_ft : Assertion +tx9_ft = Assert $ checkAsBCDT tx9 + +tx10 : TExp +tx10 = InS BCDT_L [] [tx9] + +tx10_ft : Assertion +tx10_ft = Assert $ checkAsBCDT tx10 + +-------------------------- +-------------------------- +---- Geb s-expression ---- +-------------------------- +-------------------------- + +gx1 : GExp +gx1 = InS FBT_INITIAL [] [] + +gx1_fbt : Assertion +gx1_fbt = Assert $ checkAsFinPC gx1 + +gx1' : GExp +gx1' = InS FBT_INITIAL [0] [] + +gx1'_nfbt : Assertion +gx1'_nfbt = Assert $ not $ checkAsFinPC gx1' + +gx1'' : GExp +gx1'' = InS FBT_INITIAL [] [InS FBT_INITIAL [] []] + +gx1''_nfbt : Assertion +gx1''_nfbt = Assert $ not $ checkAsFinPC gx1'' + +gx2 : GExp +gx2 = InS FBT_TERMINAL [] [] + +gx2_fbt : Assertion +gx2_fbt = Assert $ checkAsFinPC gx2 + +gx3 : GExp +gx3 = InS FBT_COPRODUCT [] [gx1, gx2] + +gx3_fbt : Assertion +gx3_fbt = Assert $ checkAsFinPC gx3 + +gx3' : GExp +gx3' = InS FBT_COPRODUCT [] [gx1] + +gx3'_nfbt : Assertion +gx3'_nfbt = Assert $ not $ checkAsFinPC gx3' + +gx3'' : GExp +gx3'' = InS FBT_COPRODUCT [0, 1] [gx1, gx2] + +gx3''_nfbt : Assertion +gx3''_nfbt = Assert $ not $ checkAsFinPC gx3'' + +gx4 : GExp +gx4 = InS FBT_PRODUCT [] [gx1, gx2] + +gx4_fbt : Assertion +gx4_fbt = Assert $ checkAsFinPC gx4 + +gx5 : GExp +gx5 = InS FBT_PRODUCT [] [gx3, gx4] + +gx5_fbt : Assertion +gx5_fbt = Assert $ checkAsFinPC gx5 + +gx5' : GExp +gx5' = InS FBT_PRODUCT [] [] + +gx5'_fbt : Assertion +gx5'_fbt = Assert $ not $ checkAsFinPC gx5' + +gx5'' : GExp +gx5'' = InS FBT_PRODUCT [] [gx3', gx4] + +gx5''_fbt : Assertion +gx5''_fbt = Assert $ not $ checkAsFinPC gx5'' + +gx6 : GExp +gx6 = InS TERM_U [] [] + +gx6_ft : Assertion +gx6_ft = Assert $ checkAsFinT gx6 + +gx7 : GExp +gx7 = InS TERM_L [] [gx6] + +gx7_ft : Assertion +gx7_ft = Assert $ checkAsFinT gx7 + +gx8 : GExp +gx8 = InS TERM_R [] [gx6] + +gx8_ft : Assertion +gx8_ft = Assert $ checkAsFinT gx8 + +gx9 : GExp +gx9 = InS TERM_P [] [gx7, gx8] + +gx9_ft : Assertion +gx9_ft = Assert $ checkAsFinT gx9 + +gx10 : GExp +gx10 = InS TERM_L [] [gx9] + +gx10_ft : Assertion +gx10_ft = Assert $ checkAsFinT gx10 + ---------------------------------- ---------------------------------- ----- Exported test function ----- diff --git a/geb-idris/src/LanguageDef/Test/GenPolyFuncTest.idr b/geb-idris/src/LanguageDef/Test/GenPolyFuncTest.idr new file mode 100644 index 000000000..a8f6f4929 --- /dev/null +++ b/geb-idris/src/LanguageDef/Test/GenPolyFuncTest.idr @@ -0,0 +1,26 @@ +module LanguageDef.Test.GenPolyFuncTest + +import Test.TestLibrary +import LanguageDef.Test.ProgFinSetTest +import LanguageDef.GenPolyFunc + +%default total + +---------------------------------- +---------------------------------- +----- Exported test function ----- +---------------------------------- +---------------------------------- + +export +genPolyFuncTest : IO () +genPolyFuncTest = do + putStrLn "" + putStrLn "======================" + putStrLn "Begin GenPolyFuncTest:" + putStrLn "----------------------" + putStrLn "" + putStrLn "--------------------" + putStrLn "End GenPolyFuncTest." + putStrLn "====================" + pure () diff --git a/geb-idris/src/LanguageDef/Test/SyntaxTest.idr b/geb-idris/src/LanguageDef/Test/SyntaxTest.idr index 479e9d728..def3c3054 100644 --- a/geb-idris/src/LanguageDef/Test/SyntaxTest.idr +++ b/geb-idris/src/LanguageDef/Test/SyntaxTest.idr @@ -261,7 +261,7 @@ gx1 : GExp gx1 = InS SL_EXP [1, 2, 3] [InS SL_NAT [2] [], InS SL_EXPL [] []] frgx1 : FrGExp String -frgx1 = InSF SL_EXP [1, 2, 3] [InSF SL_NAT [2] [], InSXV "sl_expl"] +frgx1 = InS SL_EXP [1, 2, 3] [InS SL_NAT [2] [], InSV "sl_expl"] --------------------------------------- --------------------------------------- diff --git a/geb-idris/src/Library/IdrisCategories.idr b/geb-idris/src/Library/IdrisCategories.idr index 71fe0861f..163703fad 100644 --- a/geb-idris/src/Library/IdrisCategories.idr +++ b/geb-idris/src/Library/IdrisCategories.idr @@ -33,6 +33,12 @@ record IsEquivalence {a : Type} (r : RelationOn a) where EquivSym : IsSymmetric r EquivTrans : IsTransitive r +public export +record EqRel (a : Type) where + constructor MkEq + eqRel : RelationOn a + eqCorrect : IsEquivalence eqRel + public export data EquivClosure : {a : Type} -> RelationOn a -> RelationOn a where EqClGen : {a : Type} -> {r : RelationOn a} -> {x, x' : a} -> @@ -262,6 +268,16 @@ public export SliceMorphism : {a : Type} -> SliceObj a -> SliceObj a -> Type SliceMorphism {a} s s' = (e : a) -> s e -> s' e +public export +SliceExtEq : {a : Type} -> {s, s' : SliceObj a} -> + (f, g : SliceMorphism {a} s s') -> Type +SliceExtEq {a} {s} {s'} f g = (e : a) -> ExtEq (f e) (g e) + +public export +SliceFunctorMap : {x, y : Type} -> (f : SliceFunctor x y) -> Type +SliceFunctorMap {x} {y} f = + {sa, sb : SliceObj x} -> SliceMorphism sa sb -> SliceMorphism (f sa) (f sb) + public export SliceToPi : {a : Type} -> {p : SliceObj a} -> SliceMorphism (const ()) p -> Pi p SliceToPi m x = m x () @@ -289,7 +305,7 @@ smMapFstEq m ((i ** d) :: l') = cong ((::) i) $ smMapFstEq m l' public export SliceFMorphism : {a : Type} -> SliceObj a -> (a -> a) -> Type -SliceFMorphism s f = SliceMorphism s (s . f) +SliceFMorphism s f = SliceMorphism s (BaseChangeF f s) public export ArrowObj : Type @@ -349,6 +365,222 @@ DepPolyF {w} {x} {y} {z} fxw predyx predzy = . DepProdF {a=x} {b=y} predyx . BaseChangeF fxw +------------------------------------------------------------------------------ +---- Dependent polynomial functors using predicates rather than morphisms ---- +------------------------------------------------------------------------------ + +-- These are Idris `SliceFunctor` versions of the "General Theory of +-- Interaction" style which defines polynomial functors using dependent +-- sets ("positions" and "directions"), extended to the dependent +-- (slice-category) case, whereas the ones in the previous section (`DepPolyF`) +-- correspond to a W-type-style definition. + +-- Dependent product in terms of a predicate instead of a morphism. +public export +PredDepProdF : {a : Type} -> (p : SliceObj a) -> SliceFunctor (Sigma {a} p) a +PredDepProdF {a} p slp elema = + Pi {a=(p elema)} (BaseChangeF (MkDPair elema) slp) + +-- Dependent coproduct in terms of a predicate instead of a morphism. +public export +PredDepCoprodF : {a : Type} -> (p : SliceObj a) -> SliceFunctor (Sigma {a} p) a +PredDepCoprodF {a} p slp elema = + Sigma {a=(p elema)} (BaseChangeF (MkDPair elema) slp) + +-- A dependent polynomial functor in terms of predicates instead of morphisms. +public export +PredDepPolyF : {parambase, posbase : Type} -> + (posdep : SliceObj posbase) -> + (dirdep : SliceObj (Sigma posdep)) -> + (assign : Sigma dirdep -> parambase) -> + SliceFunctor parambase posbase +PredDepPolyF {parambase} {posbase} posdep dirdep assign = + PredDepCoprodF {a=posbase} posdep + . PredDepProdF {a=(Sigma posdep)} dirdep + . BaseChangeF assign + +-- The same function as `PredDepPolyF`, but compressed into a single computation +-- purely as documentation for cases in which this might be more clear. +public export +PredDepPolyF' : {parambase, posbase : Type} -> + (posdep : SliceObj posbase) -> + (dirdep : SliceObj (Sigma posdep)) -> + (assign : Sigma dirdep -> parambase) -> + SliceFunctor parambase posbase +PredDepPolyF' posdep dirdep assign parampred posi = + (pos : posdep posi ** + ((dir : dirdep (posi ** pos)) -> parampred (assign ((posi ** pos) ** dir)))) + +public export +PredDepPolyF'_correct : {parambase, posbase : Type} -> + (posdep : SliceObj posbase) -> + (dirdep : SliceObj (Sigma posdep)) -> + (assign : Sigma dirdep -> parambase) -> + (parampred : SliceObj parambase) -> + (posi : posbase) -> + PredDepPolyF posdep dirdep assign parampred posi = + PredDepPolyF' posdep dirdep assign parampred posi +PredDepPolyF'_correct posdep dirdep assign parampred posi = Refl + +-- The morphism-map component of the functor induced by a `PredDepPolyF`. +public export +PredDepPolyFMap : {parambase, posbase : Type} -> + (posdep : SliceObj posbase) -> + (dirdep : SliceObj (Sigma posdep)) -> + (assign : Sigma dirdep -> parambase) -> + (p, p' : SliceObj parambase) -> + SliceMorphism p p' -> + SliceMorphism + (PredDepPolyF posdep dirdep assign p) + (PredDepPolyF posdep dirdep assign p') +PredDepPolyFMap posdep dirdep assign p p' m posi (pos ** dir) = + (pos ** \di => m (assign ((posi ** pos) ** di)) (dir di)) + +public export +PredDepPolyEndoF : {base : Type} -> + (posdep : SliceObj base) -> + (dirdep : SliceObj (Sigma posdep)) -> + (assign : Sigma dirdep -> base) -> + SliceFunctor base base +PredDepPolyEndoF {base} = PredDepPolyF {parambase=base} {posbase=base} + +------------------------------- +---- Dependent (co)algebra ---- +------------------------------- + +public export +SliceAlg : {a : Type} -> SliceEndofunctor a -> SliceObj a -> Type +SliceAlg sf sa = SliceMorphism (sf sa) sa + +public export +SliceCoalg : {a : Type} -> SliceEndofunctor a -> SliceObj a -> Type +SliceCoalg sf sa = SliceMorphism (sf sa) sa + +-- The slice-category version of `TranslateFunctor`. +public export +data SliceTranslateF : {a : Type} -> + SliceEndofunctor a -> SliceObj a -> SliceEndofunctor a where + InSlV : {a : Type} -> {f : SliceEndofunctor a} -> {0 sv, sa : SliceObj a} -> + {ea : a} -> sv ea -> SliceTranslateF {a} f sv sa ea + InSlC : {a : Type} -> {f : SliceEndofunctor a} -> {0 sv, sa : SliceObj a} -> + {ea : a} -> f sa ea -> SliceTranslateF {a} f sv sa ea + +public export +SliceTrEitherF : {a : Type} -> SliceEndofunctor a -> SliceObj a -> SliceObj a +SliceTrEitherF {a} f sa = SliceTranslateF {a} f sa sa + +-- The slice-category version of `ScaleFunctor`. +public export +data SliceScaleF : {a : Type} -> + SliceEndofunctor a -> SliceObj a -> SliceEndofunctor a where + InSlS : {a : Type} -> {f : SliceEndofunctor a} -> {0 sv, sa : SliceObj a} -> + {ea : a} -> sv ea -> f sa ea -> SliceScaleF {a} f sv sa ea + +-- The free monad in a slice category. +public export +data SliceFreeM : {a : Type} -> SliceEndofunctor a -> SliceEndofunctor a where + InSlF : {a : Type} -> {f : SliceEndofunctor a} -> {sa : SliceObj a} -> + SliceAlg {a} (SliceTranslateF {a} f sa) (SliceFreeM {a} f sa) + +public export +InSlFv : {a : Type} -> {f : SliceEndofunctor a} -> {sa : SliceObj a} -> + {ea : a} -> sa ea -> SliceFreeM {a} f sa ea +InSlFv {a} {f} {sa} {ea} sea = + InSlF {a} {f} {sa} ea + (InSlV {a} {f} {sv=sa} {sa=(SliceFreeM {a} f sa)} {ea} sea) + +public export +InSlFc : {a : Type} -> {f : SliceEndofunctor a} -> {sa : SliceObj a} -> + {ea : a} -> f (SliceFreeM {a} f sa) ea -> SliceFreeM {a} f sa ea +InSlFc {a} {f} {sa} {ea} fsea = + InSlF {a} {f} {sa} ea + (InSlC {a} {f} {sv=sa} {sa=(SliceFreeM {a} f sa)} {ea} fsea) + +-- The type of free catamorphisms in slice categories. +public export +SliceFreeCata : {a : Type} -> SliceEndofunctor a -> Type +SliceFreeCata {a} f = + (sv, sa : SliceObj a) -> SliceMorphism {a} sv sa -> SliceAlg f sa -> + SliceMorphism {a} (SliceFreeM f sv) sa + +public export +SliceMu : {a : Type} -> SliceEndofunctor a -> SliceObj a +SliceMu {a} f = SliceFreeM {a} f (const Void) + +-- The type of catamorphisms in slice categories. +public export +SliceCata : {a : Type} -> SliceEndofunctor a -> Type +SliceCata {a} f = + (sa : SliceObj a) -> SliceAlg f sa -> SliceMorphism {a} (SliceMu f) sa + +-- The cofree comonad in a slice category. +public export +data SliceCofreeCM : {a : Type} -> SliceEndofunctor a -> SliceEndofunctor a + where + InSlCF : {a : Type} -> {f : SliceEndofunctor a} -> {sa : SliceObj a} -> + -- "Inf (SliceAlg {a} (SliceScaleF {a} f sa) (SliceCofreeCM {a} f sa))" + (ea : a) -> + Inf (SliceScaleF {a} f sa (SliceCofreeCM {a} f sa) ea) -> + SliceCofreeCM {a} f sa ea + +-- The type of cofree anamorphisms in slice categories. +public export +SliceCofreeAna : {a : Type} -> SliceEndofunctor a -> Type +SliceCofreeAna {a} f = + (sl, sa : SliceObj a) -> SliceMorphism {a} sa sl -> SliceCoalg f sa -> + SliceMorphism {a} sa (SliceCofreeCM f sl) + +public export +SliceNu : {a : Type} -> SliceEndofunctor a -> SliceObj a +SliceNu {a} f = SliceCofreeCM {a} f (const Unit) + +-- The type of anamorphisms in slice categories. +public export +SliceAna : {a : Type} -> SliceEndofunctor a -> Type +SliceAna {a} f = + (sa : SliceObj a) -> SliceCoalg f sa -> SliceMorphism {a} sa (SliceNu f) + +----------------------------- +----------------------------- +---- Dependent relations ---- +----------------------------- +----------------------------- + +public export +DepRelObj : {a : Type} -> SliceObj (SliceObj a, SliceObj a) +DepRelObj {a} (sl, sl') = (x : a ** (sl x, sl' x)) + +public export +DepRelOn : {a : Type} -> SliceObj (SliceObj a, SliceObj a) +DepRelOn {a} sls = SliceObj (DepRelObj {a} sls) + +public export +data FreeEqF : {0 a : Type} -> RelationOn a -> RelationOn a where + FErefl : {0 a : Type} -> {0 rel : RelationOn a} -> + (0 x : a) -> FreeEqF {a} rel x x + FEsym : {0 a : Type} -> {0 rel : RelationOn a} -> + (0 x, y : a) -> rel x y -> FreeEqF {a} rel y x + FEtrans : {0 a : Type} -> {0 rel : RelationOn a} -> + (0 x, y, z : a) -> rel y z -> rel x y -> FreeEqF {a} rel x z + +public export +data DepFreeEqF : {0 a : Type} -> {sl : SliceObj a} -> + SliceEndofunctor (DepRelObj {a} (sl, sl)) where + DFErefl : + {0 a : Type} -> {0 sl : SliceObj a} -> {0 rel : DepRelOn {a} (sl, sl)} -> + {0 x : a} -> (0 sx : sl x) -> DepFreeEqF {a} {sl} rel (x ** (sx, sx)) + DFEsym : + {0 a : Type} -> {0 sl : SliceObj a} -> {0 rel : DepRelOn {a} (sl, sl)} -> + {0 x : a} -> {0 sx, sx' : sl x} -> + rel (x ** (sx, sx')) -> + DepFreeEqF {a} {sl} rel (x ** (sx', sx)) + DFEtrans : + {0 a : Type} -> {0 sl : SliceObj a} -> {0 rel : DepRelOn {a} (sl, sl)} -> + {0 x : a} -> {0 sx, sx', sx'' : sl x} -> + rel (x ** (sx', sx'')) -> + rel (x ** (sx, sx')) -> + DepFreeEqF {a} {sl} rel (x ** (sx, sx'')) + ---------------------------------------------------- ---------------------------------------------------- ---- Natural transformations and their algebras ---- @@ -1432,89 +1664,103 @@ Coalgebra : (Type -> Type) -> Type -> Type Coalgebra f a = a -> f a -- For a given functor `F` and object `v`, form the functor `Fv` defined by --- `Fv[x] = v + F[x]`. We call it `TermFunctor` because it turns --- an endofunctor which we can interpret as representing a datatype --- into one which we can interpret as representing open terms of --- that datatype with variables drawn from type `v`. +-- `Fv[x] = v + F[x]`. We call it `TranslateFunctor` because it adds +-- a constant functor (in effect, a type) to a given functor. +-- This functor can be used to turn an endofunctor which we can interpret as +-- representing a datatype into one which we can interpret as representing +-- open terms of that datatype with variables drawn from type `v`. +-- It is the dual of `ScaleFunctor`. +public export +data TranslateFunctor : (Type -> Type) -> Type -> (Type -> Type) where + TFV : {f : Type -> Type} -> {0 v, a : Type} -> + v -> TranslateFunctor f v a + TFC : {f : Type -> Type} -> {0 v, a : Type} -> + f a -> TranslateFunctor f v a + +public export +trElim : {0 f : Type -> Type} -> {0 v, a, x : Type} -> + (v -> x) -> (f a -> x) -> TranslateFunctor f v a -> x +trElim {f} {v} {a} {x} fv ff (TFV ev) = fv ev +trElim {f} {v} {a} {x} fv ff (TFC efa) = ff efa + public export -data TermFunctor : (Type -> Type) -> Type -> (Type -> Type) where - TermVar : {f : Type -> Type} -> {0 v, a : Type} -> - v -> TermFunctor f v a - TermComposite : {f : Type -> Type} -> {0 v, a : Type} -> - f a -> TermFunctor f v a +Functor f => Bifunctor (TranslateFunctor f) where + bimap f' g' (TFV x) = TFV $ f' x + bimap f' g' (TFC x) = TFC $ map g' x public export -Functor f => Bifunctor (TermFunctor f) where - bimap f' g' (TermVar x) = TermVar $ f' x - bimap f' g' (TermComposite x) = TermComposite $ map g' x +TrEitherF : (Type -> Type) -> (Type -> Type) +TrEitherF f a = TranslateFunctor f a a public export -LimitIterF : (Type -> Type) -> (Type -> Type) -LimitIterF f a = TermFunctor f a a +sliceTrMap : {a : Type} -> {f : Type -> Type} -> + (SliceObj a -> SliceObj (f a)) -> + SliceObj a -> SliceObj (TrEitherF f a) +sliceTrMap {a} {f} m sa = trElim {f} {v=a} {a} {x=Type} sa (m sa) -- For a given functor `F`, form the functor `Fa` defined by --- `Fa[x] = a * F[x]`. We call it `TreeFunctor` because it turns --- an endofunctor which we can interpret as representing a datatype --- into one which we can interpret as representing potentially infinite --- trees of that datatype with labels drawn from type `v`. --- This is the dual of `TermFunctor`. +-- `Fa[x] = a * F[x]`. We call it `ScaleFunctor` because it multiplies +-- This functor can be used to turn an endofunctor which we can interpret as +-- representing a datatype into one which we can interpret as representing +-- potentially infinite trees of that datatype with labels drawn from type `v`. +-- It is the dual of `TranslateFunctor`. public export -data TreeFunctor : (Type -> Type) -> Type -> (Type -> Type) where - TreeNode : {f : Type -> Type} -> {0 l, a : Type} -> - l -> f a -> TreeFunctor f l a +data ScaleFunctor : (Type -> Type) -> Type -> (Type -> Type) where + SFN : {f : Type -> Type} -> {0 l, a : Type} -> + l -> f a -> ScaleFunctor f l a export -Functor f => Bifunctor (TreeFunctor f) where - bimap f' g' (TreeNode x fx) = TreeNode (f' x) (map g' fx) +Functor f => Bifunctor (ScaleFunctor f) where + bimap f' g' (SFN x fx) = SFN (f' x) (map g' fx) public export ColimitIterF : (Type -> Type) -> (Type -> Type) -ColimitIterF f a = TreeFunctor f a a +ColimitIterF f a = ScaleFunctor f a a export -treeLabel : {f : Type -> Type} -> {l, a : Type} -> TreeFunctor f l a -> l -treeLabel (TreeNode a' _) = a' +treeLabel : {f : Type -> Type} -> {l, a : Type} -> ScaleFunctor f l a -> l +treeLabel (SFN a' _) = a' export -treeSubtree : {f : Type -> Type} -> {l, a : Type} -> TreeFunctor f l a -> f a -treeSubtree (TreeNode _ fx) = fx +treeSubtree : {f : Type -> Type} -> {l, a : Type} -> ScaleFunctor f l a -> f a +treeSubtree (SFN _ fx) = fx -- An algebra on a functor representing a type of open terms (as generated --- by `TermFunctor` above) may be viewed as a polymorphic algebra, because +-- by `TranslateFunctor` above) may be viewed as a polymorphic algebra, because -- for each object `v` it generates an `F[v]`-algebra on an any given carrier -- object. When `v` is the initial object (`Void`), it specializes to -- generating `F`-algebras. public export TermAlgebra : (Type -> Type) -> Type -> Type -> Type -TermAlgebra f v a = Algebra (TermFunctor f v) a +TermAlgebra f v a = Algebra (TranslateFunctor f v) a public export voidAlg : {f : Type -> Type} -> {a : Type} -> Algebra f a -> TermAlgebra f Void a -voidAlg alg (TermVar {v=Void} _) impossible -voidAlg alg (TermComposite x) = alg x +voidAlg alg (TFV {v=Void} _) impossible +voidAlg alg (TFC x) = alg x public export TermCoalgebra : (Type -> Type) -> Type -> Type -> Type -TermCoalgebra f v a = Coalgebra (TermFunctor f v) a +TermCoalgebra f v a = Coalgebra (TranslateFunctor f v) a -- A coalgebra on a functor representing a type of labeled trees (as generated --- by `TreeFunctor` above) may be viewed as a polymorphic coalgebra, because +-- by `ScaleFunctor` above) may be viewed as a polymorphic coalgebra, because -- for each object `v` it generates an `F[v]`-coalgebra on an any given carrier -- object. When `v` is the terminal object (`Unit`), it specializes to -- generating `F`-coalgebras. public export TreeCoalgebra : (Type -> Type) -> Type -> Type -> Type -TreeCoalgebra f v a = Coalgebra (TreeFunctor f v) a +TreeCoalgebra f v a = Coalgebra (ScaleFunctor f v) a public export unitCoalg : {f : Type -> Type} -> {a : Type} -> Coalgebra f a -> TreeCoalgebra f Unit a -unitCoalg alg x = TreeNode {l=()} () $ alg x +unitCoalg alg x = SFN {l=()} () $ alg x public export TreeAlgebra : (Type -> Type) -> Type -> Type -> Type -TreeAlgebra f v a = Algebra (TreeFunctor f v) a +TreeAlgebra f v a = Algebra (ScaleFunctor f v) a -------------------------------------------------- ---- Initial algebras and terminal coalgebras ---- @@ -1559,7 +1805,7 @@ public export data CofreeComonad : (Type -> Type) -> (Type -> Type) where InCofree : {f : Type -> Type} -> {a : Type} -> - Inf (TreeFunctor f a (CofreeComonad f a)) -> CofreeComonad f a + Inf (ScaleFunctor f a (CofreeComonad f a)) -> CofreeComonad f a public export CofreeCoalgebra : (Type -> Type) -> Type -> Type @@ -1584,21 +1830,21 @@ TerminalCoalgebra : (Type -> Type) -> Type TerminalCoalgebra f = CofreeCoalgebra f Unit public export -inFreeVar : {f : Type -> Type} -> Coalgebra (FreeMonad f) a -inFreeVar = InFree . TermVar +inFV : {f : Type -> Type} -> Coalgebra (FreeMonad f) a +inFV = InFree . TFV public export -inFreeComposite : {f : Type -> Type} -> Algebra f (FreeMonad f a) -inFreeComposite = InFree . TermComposite +inFC : {f : Type -> Type} -> Algebra f (FreeMonad f a) +inFC = InFree . TFC public export outFree : TermCoalgebra f a (FreeMonad f a) outFree (InFree x) = x public export -inCofreeTree : {a : Type} -> {f : Type -> Type} -> +inCN : {a : Type} -> {f : Type -> Type} -> a -> Algebra f (CofreeComonad f a) -inCofreeTree x fx = InCofree $ TreeNode x fx +inCN x fx = InCofree $ SFN x fx public export outCofree : {f : Type -> Type} -> {a : Type} -> @@ -1710,7 +1956,7 @@ CofreeAdjCounit m f = CofreeNaturalTransformation m f id public export natTransFreeAlg : {f, g : Type -> Type} -> NaturalTransformation f g -> FreeAdjCounit g f -natTransFreeAlg {f} {g} nt a = InFree . TermComposite . nt (FreeMonad g a) +natTransFreeAlg {f} {g} nt a = InFree . TFC . nt (FreeMonad g a) public export natTransMapFree : @@ -1720,7 +1966,7 @@ natTransMapFree : FreeMonadNatTrans f g natTransMapFree {f} {g} cataF nt carrier = cataF carrier - (FreeMonad g carrier) (InFree . TermVar) (natTransFreeAlg nt carrier) + (FreeMonad g carrier) (InFree . TFV) (natTransFreeAlg nt carrier) ----------------------------- ---- Polynomial algebras ---- @@ -1768,13 +2014,13 @@ public export partial muFree : Functor f => TermAlgebra f v a -> FreeMonad f v -> a muFree alg (InFree x) = alg $ case x of - TermVar x => TermVar x - TermComposite x => TermComposite $ map (muFree alg) x + TFV x => TFV x + TFC x => TFC $ map (muFree alg) x public export -voidalg : Algebra f a -> Algebra (TermFunctor f Void) a -voidalg alg (TermVar _) impossible -voidalg alg (TermComposite x) = alg x +voidalg : Algebra f a -> Algebra (TranslateFunctor f Void) a +voidalg alg (TFV _) impossible +voidalg alg (TFC x) = alg x public export partial @@ -1786,7 +2032,7 @@ partial adjointFoldFree : {f : Type -> Type} -> (Functor f, Functor l, Functor r) => (counit : (a : Type) -> l (r a) -> a) -> {v, a : Type} -> - Algebra (TermFunctor f v) (r a) -> l (FreeMonad f v) -> a + Algebra (TranslateFunctor f v) (r a) -> l (FreeMonad f v) -> a adjointFoldFree counit {a} alg = counit a . map {f=l} (muFree alg) export @@ -1799,10 +2045,10 @@ adjointFold counit {a} alg = counit a . map {f=l} (mu alg) public export partial nuFree : {f : Type -> Type} -> Functor f => {v, a : Type} -> - Coalgebra (TreeFunctor f v) a -> a -> CofreeComonad f v + Coalgebra (ScaleFunctor f v) a -> a -> CofreeComonad f v nuFree coalg x with (coalg x) - nuFree coalg x | TreeNode x' v' = - InCofree $ TreeNode x' $ map (nuFree coalg) v' + nuFree coalg x | SFN x' v' = + InCofree $ SFN x' $ map (nuFree coalg) v' export partial @@ -1810,13 +2056,13 @@ adjointUnfoldFree : {f, l, r : Type -> Type} -> (Functor f, Functor l, Functor r) => (unit : (a : Type) -> a -> r (l a)) -> {v, a : Type} -> - Coalgebra (TreeFunctor f v) (l a) -> a -> r (CofreeComonad f v) + Coalgebra (ScaleFunctor f v) (l a) -> a -> r (CofreeComonad f v) adjointUnfoldFree unit {a} coalg = map {f=r} (nuFree coalg) . unit a public export unitcoalg : {f : Type -> Type} -> {a : Type} -> - Coalgebra f a -> Coalgebra (TreeFunctor f ()) a -unitcoalg coalg = TreeNode () . coalg + Coalgebra f a -> Coalgebra (ScaleFunctor f ()) a +unitcoalg coalg = SFN () . coalg export partial @@ -1840,15 +2086,15 @@ partial hyloFree : {v, c, a : Type} -> {d, l, r : Type -> Type} -> (Functor d, Functor l, Functor r) => (unit : (ty : Type) -> ty -> r (l ty)) -> - (coalg : c -> (TreeFunctor d v) c) -> - (alg : (l c, (l . (TreeFunctor d v) . r) a) -> a) -> + (coalg : c -> (ScaleFunctor d v) c) -> + (alg : (l c, (l . (ScaleFunctor d v) . r) a) -> a) -> l c -> a hyloFree unit coalg alg x = let - transport = map {f=l} . map {f=(TreeFunctor d v)} . map {f=r} + transport = map {f=l} . map {f=(ScaleFunctor d v)} . map {f=r} hylo_trans = transport $ hyloFree unit coalg alg unfolded = map {f=l} coalg x - unfolded_trans = map (map {f=(TreeFunctor d v)} (unit c)) unfolded + unfolded_trans = map (map {f=(ScaleFunctor d v)} (unit c)) unfolded in alg (x, hylo_trans unfolded_trans) @@ -1863,7 +2109,7 @@ hylomorphism : {c, a : Type} -> hylomorphism {d} {l} {r} unit coalg alg = hyloFree {v=()} {d} {l} {r} unit (unitcoalg coalg) unitalg where - unitalg : (l c, (l . TreeFunctor d () . r) a) -> a + unitalg : (l c, (l . ScaleFunctor d () . r) a) -> a unitalg (x, x') = alg (x, map treeSubtree x') ---------------------------------------- @@ -1975,8 +2221,8 @@ FinCovarHomAlgToAlg {n=(S n)} alg (x, p) = FinCovarHomAlgToAlg (alg x) p public export finCovarFreeAlgebra : (n : Nat) -> (0 a : Type) -> FreeAlgebra (FinCovarHomFunc n) a -finCovarFreeAlgebra Z a x = InFree $ TermComposite () -finCovarFreeAlgebra (S n) a (x, p) = InFree $ TermComposite (x, p) +finCovarFreeAlgebra Z a x = InFree $ TFC () +finCovarFreeAlgebra (S n) a (x, p) = InFree $ TFC (x, p) public export FinCovarInitialAlgebra : (n : Nat) -> InitialAlgebra (FinCovarHomFunc n) @@ -1986,8 +2232,8 @@ mutual public export cataFinCovar : (n : Nat) -> ParamCata (FinCovarHomFunc n) cataFinCovar n v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ case n of + TFV var => subst var + TFC com => alg $ case n of Z => com S n' => case com of (x', com') => @@ -2008,26 +2254,26 @@ finCovarMap : {n : Nat} -> {a, b : Type} -> (a -> b) -> FreeFinCovar n a -> FreeFinCovar n b finCovarMap {n} {a} {b} f = cataFinCovar n a (FreeFinCovar n b) - (InFree . TermVar . f) - (InFree . TermComposite) + (InFree . TFV . f) + (InFree . TFC) public export finCovarMapN : {n, n' : Nat} -> {a, b : Type} -> (a -> b) -> ProductN n (FreeFinCovar n' a) -> ProductN n (FreeFinCovar n' b) finCovarMapN {n} {n'} f = cataFinCovarN n n' a (FreeFinCovar n' b) - (InFree . TermVar . f) - (InFree . TermComposite) + (InFree . TFV . f) + (InFree . TFC) public export finCovarReturn : {n : Nat} -> {0 a : Type} -> a -> FreeFinCovar n a -finCovarReturn x = InFree $ TermVar x +finCovarReturn x = InFree $ TFV x public export finCovarBigStepCata : {n : Nat} -> ParamBigStepCata (FinCovarHomFunc n) finCovarBigStepCata {n} v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ InFree $ TermComposite $ + TFV var => subst var + TFC com => alg $ InFree $ TFC $ mapProductN n (finCovarMap subst) com public export @@ -2046,14 +2292,14 @@ mutual FreeFinCovar n a -> FreeFinCovar n b finCovarApply (InFree f) (InFree x) = InFree $ case (f, x) of - (TermVar fv, TermVar xv) => - TermVar $ fv xv - (TermVar fv, TermComposite xc) => - TermComposite $ finCovarMapN fv xc - (TermComposite fc, TermVar xv) => - TermComposite $ finCovarApplyN1 fc xv - (TermComposite fc, TermComposite xc) => - TermComposite $ finCovarApplyNN fc xc + (TFV fv, TFV xv) => + TFV $ fv xv + (TFV fv, TFC xc) => + TFC $ finCovarMapN fv xc + (TFC fc, TFV xv) => + TFC $ finCovarApplyN1 fc xv + (TFC fc, TFC xc) => + TFC $ finCovarApplyNN fc xc public export partial @@ -2061,10 +2307,10 @@ mutual FreeFinCovar n (a -> b) -> a -> FreeFinCovar n b - finCovarApply11 {n=Z} (InFree f) x = InFree $ TermComposite () + finCovarApply11 {n=Z} (InFree f) x = InFree $ TFC () finCovarApply11 {n=(S n)} (InFree f) x = InFree $ case f of - TermVar fv => TermVar $ fv x - TermComposite (f, fp) => TermComposite $ + TFV fv => TFV $ fv x + TFC (f, fp) => TFC $ (finCovarApply11 f x, finCovarApplyN1 fp x) public export @@ -2088,14 +2334,14 @@ mutual let recnn = finCovarApplyNN fp xp recapply = InFree $ case (f, x) of - (TermVar fv, TermVar xv) => - TermVar $ fv xv - (TermVar fv, TermComposite xc) => - TermComposite $ finCovarMapN fv xc - (TermComposite fc, TermVar xv) => - TermComposite $ finCovarApplyN1 fc xv - (TermComposite fc, TermComposite xc) => - TermComposite $ finCovarApplyNN fc xc + (TFV fv, TFV xv) => + TFV $ fv xv + (TFV fv, TFC xc) => + TFC $ finCovarMapN fv xc + (TFC fc, TFV xv) => + TFC $ finCovarApplyN1 fc xv + (TFC fc, TFC xc) => + TFC $ finCovarApplyNN fc xc in (recapply, recnn) @@ -2104,8 +2350,8 @@ mutual finCovarJoin : {n : Nat} -> {0 a : Type} -> FreeFinCovar n (FreeFinCovar n a) -> FreeFinCovar n a finCovarJoin (InFree x) = case x of - TermVar var => var - TermComposite com => finCovarFreeAlgebra n a $ finCovarJoinN com + TFV var => var + TFC com => finCovarFreeAlgebra n a $ finCovarJoinN com public export finCovarJoinN : {n, n' : Nat} -> {0 a : Type} -> @@ -2173,7 +2419,7 @@ public export finPolyFreeAlgebra : (fpd : FinPolyData) -> (0 a : Type) -> FreeAlgebra (FinPolyFunc fpd) a finPolyFreeAlgebra [] a v = void v -finPolyFreeAlgebra fpd a x = InFree $ TermComposite x +finPolyFreeAlgebra fpd a x = InFree $ TFC x public export FinPolyInitialAlgebra : (fpd : FinPolyData) -> InitialAlgebra (FinPolyFunc fpd) @@ -2183,8 +2429,8 @@ mutual public export cataFinPoly : (fpd : FinPolyData) -> ParamCata (FinPolyFunc fpd) cataFinPoly fpd v a subst alg (InFree poly) = case poly of - TermVar var => subst var - TermComposite com => alg $ case fpd of + TFV var => subst var + TFC com => alg $ case fpd of [] => void com ((coeff, pow) :: terms) => case com of Left fields => Left $ cataFinPolyFuncN subst alg . fields -- (c, cataFinPolyFuncN subst alg p) @@ -2224,7 +2470,7 @@ freeFinPolyMap : {fpd : FinPolyData} -> {a, b : Type} -> (a -> b) -> FreeFinPoly fpd a -> FreeFinPoly fpd b freeFinPolyMap {fpd} {a} {b} f = cataFinPoly fpd - a (FreeFinPoly fpd b) (InFree . TermVar . f) (InFree . TermComposite) + a (FreeFinPoly fpd b) (InFree . TFV . f) (InFree . TFC) public export finPolyFuncMap : {fpd, fpd' : FinPolyData} -> {a, b : Type} -> @@ -2233,7 +2479,7 @@ finPolyFuncMap : {fpd, fpd' : FinPolyData} -> {a, b : Type} -> finPolyFuncMap {a} {b} f = cataFinPolyFunc {v=a} {a=(FreeFinPoly fpd' b)} - (InFree . TermVar . f) (InFree . TermComposite) + (InFree . TFV . f) (InFree . TFC) public export freeFinPolyMapN : {pow : Nat} -> {fpd : FinPolyData} -> {a, b : Type} -> @@ -2241,18 +2487,18 @@ freeFinPolyMapN : {pow : Nat} -> {fpd : FinPolyData} -> {a, b : Type} -> ProductN pow (FreeFinPoly fpd a) -> ProductN pow (FreeFinPoly fpd b) freeFinPolyMapN {pow} {fpd} {a} {b} f = cataFinPolyFuncN {fpd} {v=a} {a=(FreeFinPoly fpd b)} - (InFree . TermVar . f) (InFree . TermComposite) + (InFree . TFV . f) (InFree . TFC) public export finPolyReturn : {fpd : FinPolyData} -> {0 a : Type} -> a -> FreeFinPoly fpd a -finPolyReturn x = InFree $ TermVar x +finPolyReturn x = InFree $ TFV x public export finPolyBigStepCata : {fpd : FinPolyData} -> ParamBigStepCata (FinPolyFunc fpd) finPolyBigStepCata {fpd} v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ InFree $ TermComposite $ finPolyFuncMap subst com + TFV var => subst var + TFC com => alg $ InFree $ TFC $ finPolyFuncMap subst com public export finPolyBigStepCataFunc : (fpd, fpd' : FinPolyData) -> (v, a : Type) -> @@ -2282,19 +2528,19 @@ mutual FreeFinPoly fpd b finPolyApply {fpd} (InFree f) (InFree x) = InFree $ case fpd of [] => case f of - TermVar fvar => TermVar $ case x of - TermVar xvar => fvar xvar - TermComposite xcom => void xcom - TermComposite fcom => void fcom + TFV fvar => TFV $ case x of + TFV xvar => fvar xvar + TFC xcom => void xcom + TFC fcom => void fcom ((coeff, pow) :: terms) => case (f, x) of - (TermVar fv, TermVar xv) => TermVar $ fv xv - (TermVar fv, TermComposite xc) => TermComposite $ case xc of + (TFV fv, TFV xv) => TFV $ fv xv + (TFV fv, TFC xc) => TFC $ case xc of Left fields => Left $ freeFinPolyMapN fv . fields Right xcr => Right $ finPolyFuncMap fv xcr - (TermComposite fc, TermVar xv) => TermComposite $ case fc of + (TFC fc, TFV xv) => TFC $ case fc of Left fields => Left $ mapProductN pow (finPolyApply11 xv) . fields Right terms => Right $ finPolyApplyF1 xv terms - (TermComposite fc, TermComposite xc) => TermComposite $ case (fc, xc) of + (TFC fc, TFC xc) => TFC $ case (fc, xc) of (Left ffields, Left xfields) => Left $ \c => finPolyApplyNN (ffields c) (xfields c) (Left ffields, Right xterms) => @@ -2308,8 +2554,8 @@ mutual finPolyApply11 : {fpd : FinPolyData} -> {a, b : Type} -> a -> FreeFinPoly fpd (a -> b) -> FreeFinPoly fpd b finPolyApply11 ax (InFree fx) = InFree $ case fx of - TermVar fv => TermVar $ fv ax - TermComposite fcom => TermComposite $ finPolyApplyF1 ax fcom + TFV fv => TFV $ fv ax + TFC fcom => TFC $ finPolyApplyF1 ax fcom public export finPolyApplyNF : {pow : Nat} -> {fpd, fpd' : FinPolyData} -> {a, b : Type} -> @@ -2327,13 +2573,13 @@ mutual FreeFinPoly fpd' b finPolyApplyFP {fpd=[]} (InFree fx) v = void v finPolyApplyFP {fpd=((coeff, pow) :: terms)} (InFree fx) xp = case (fx, xp) of - (TermVar fv, Left xfields) => - InFree $ TermComposite $ finPolyApplyFP_hole_fvxf - (TermComposite fc, Left xfields) => + (TFV fv, Left xfields) => + InFree $ TFC $ finPolyApplyFP_hole_fvxf + (TFC fc, Left xfields) => finPolyApplyFP_hole_fcxf - (TermVar fv, Right xterms) => + (TFV fv, Right xterms) => finPolyApplyFP_hole_fvxt - (TermComposite fc, Right xterms) => + (TFC fc, Right xterms) => finPolyApplyFP_hole_fcxt public export @@ -2377,8 +2623,8 @@ mutual finPolyJoin : {fpd : FinPolyData} -> {0 a : Type} -> FreeFinPoly fpd (FreeFinPoly fpd a) -> FreeFinPoly fpd a finPolyJoin {fpd} {a} (InFree x) = case x of - TermVar var => var - TermComposite com => finPolyFreeAlgebra fpd a $ finPolyJoinFunc com + TFV var => var + TFC com => finPolyFreeAlgebra fpd a $ finPolyJoinFunc com public export finPolyJoinN : {pow : Nat} -> {fpd : FinPolyData} -> {0 a : Type} -> @@ -2851,7 +3097,7 @@ interface (Functor f, Monad m) => FreeLike f m where public export FreeMonadFreeLike : {f : Type -> Type} -> Functor f -> {auto isM : Monad (FreeMonad f)} -> FreeLike f (FreeMonad f) -FreeMonadFreeLike isF {isM} = MkFreeLike $ \a, x => InFree $ TermComposite x +FreeMonadFreeLike isF {isM} = MkFreeLike $ \a, x => InFree $ TFC x public export CodensityFreeLike : {f, m : Type -> Type} -> @@ -2911,6 +3157,13 @@ extendDensity : (0 f : Type -> Type) -> {isF : Functor f} -> {0 a, b : Type} -> (Density f a -> b) -> Density f a -> Density f b extendDensity f {isF} {a} m = map {f=(Density f)} m . duplicateDensity f +public export +joinDensity : (0 f : Type -> Type) -> {0 isF : Functor f} -> {0 a : Type} -> + Density f (Density f a) -> Density f a +joinDensity f {isF} {a} = + let _ = DensityFunctor f {isF} in + map {f=(Density f)} (eraseDensity f {a}) + ---------------------------- ---------------------------- ---- Closure conversion ---- @@ -2971,8 +3224,8 @@ mutual public export cataNatCovar : ParamCata NatCovarHomFunc cataNatCovar v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ (cataNatCovar v a subst alg) . com + TFV var => subst var + TFC com => alg $ (cataNatCovar v a subst alg) . com -} public export @@ -3025,8 +3278,8 @@ NuNat = Nu NatF public export cataNatF : ParamCata NatF cataNatF v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite n => alg $ case n of + TFV var => subst var + TFC n => alg $ case n of ZeroF => ZeroF SuccF n' => SuccF $ cataNatF v a subst alg n' @@ -3049,11 +3302,11 @@ interpMuNatF = interpFreeNatF {v=Void} (voidF Nat) public export NatFZ : FreeMonad NatF a -NatFZ = InFree $ TermComposite ZeroF +NatFZ = InFree $ TFC ZeroF public export NatFS : FreeMonad NatF a -> FreeMonad NatF a -NatFS = InFree . TermComposite . SuccF +NatFS = InFree . TFC . SuccF --------------------------------------- ---- Natural numbers as a category ---- @@ -5693,8 +5946,8 @@ NuList = Nu . ListF public export cataListF : {atom : Type} -> ParamCata $ ListF atom cataListF v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite l => alg $ case l of + TFV var => subst var + TFC l => alg $ case l of NilF => NilF ConsF x l' => ConsF x $ cataListF v a subst alg l' @@ -5849,7 +6102,7 @@ sigmaCompose {f} m' m x y = m' (f x) $ m x y -- by specializing the index to `Type`). public export ProductCatObject : Type -> Type -ProductCatObject idx = idx -> Type +ProductCatObject = SliceObj public export FunctorCatObject : Type @@ -5858,7 +6111,7 @@ FunctorCatObject = ProductCatObject Type public export ProductCatMorphism : {idx : Type} -> ProductCatObject idx -> ProductCatObject idx -> Type -ProductCatMorphism {idx} dom cod = (i : idx) -> dom i -> cod i +ProductCatMorphism {idx} = SliceMorphism {a=idx} public export FunctorCatMorphism : FunctorCatObject -> FunctorCatObject -> Type @@ -5866,7 +6119,7 @@ FunctorCatMorphism = ProductCatMorphism {idx=Type} public export ProductCatObjectMap : Type -> Type -> Type -ProductCatObjectMap idx idx' = ProductCatObject idx -> ProductCatObject idx' +ProductCatObjectMap = SliceFunctor public export FunctorCatObjectMap : Type @@ -5883,10 +6136,7 @@ FunctorCatObjectEndoMap = ProductCatObjectEndoMap Type public export ProductCatMorphismMap : {idx, idx' : Type} -> ProductCatObjectMap idx idx' -> Type -ProductCatMorphismMap {idx} {idx'} objmap = - (dom, cod : ProductCatObject idx) -> - (m : ProductCatMorphism dom cod) -> - ProductCatMorphism (objmap dom) (objmap cod) +ProductCatMorphismMap {idx} {idx'} = SliceFunctorMap {x=idx} {y=idx'} public export FunctorCatMorphismMap : FunctorCatObjectMap -> Type @@ -5935,7 +6185,7 @@ ProductCatCoalgebra : {idx : Type} -> ProductCatObjectEndoMap idx -> ProductCatObject idx -> Type ProductCatCoalgebra f a = ProductCatMorphism a (f a) --- The product-category version of `TermFunctor`. In the case of just two +-- The product-category version of `TranslateFunctor`. In the case of just two -- categories, for example, if `F` and `G` are the components of the input -- functor, each going from the product category to one of the components, -- and `v` and `w` are the components of the variable type, then this @@ -5959,7 +6209,7 @@ data ProductCatTermFunctor : {idx : Type} -> f a i -> ProductCatTermFunctor f v a i -- The dual of `ProductCatTermFunctor`, also known as the product-category --- version of `TreeFunctor`. +-- version of `ScaleFunctor`. public export data ProductCatTreeFunctor : {idx : Type} -> ProductCatObjectEndoMap idx -> @@ -6813,31 +7063,31 @@ CFunctorIterInterpPred {cat} f a = -------------------------------------- -- For a given functor `F` and object `v`, form the functor `Fv` defined by --- `Fv[x] = v + F[x]`. We call it `TermFunctor` because it turns +-- `Fv[x] = v + F[x]`. We call it `TranslateFunctor` because it turns -- an endofunctor which we can interpret as representing a datatype -- into one which we can interpret as representing open terms of -- that datatype with variables drawn from type `v`. public export -TermFunctor' : (Type -> Type) -> Type -> (Type -> Type) -TermFunctor' f a = CoproductF (ConstF a) f +TranslateFunctor' : (Type -> Type) -> Type -> (Type -> Type) +TranslateFunctor' f a = CoproductF (ConstF a) f public export -Functor f => Bifunctor (TermFunctor' f) where +Functor f => Bifunctor (TranslateFunctor' f) where bimap f' g' (Left x) = Left $ f' x bimap f' g' (Right x) = Right $ map g' x -- For a given functor `F`, form the functor `Fa` defined by --- `Fa[x] = a * F[x]`. We call it `TreeFunctor` because it turns +-- `Fa[x] = a * F[x]`. We call it `ScaleFunctor` because it turns -- an endofunctor which we can interpret as representing a datatype -- into one which we can interpret as representing potentially infinite -- trees of that datatype with labels drawn from type `v`. --- This is the dual of `TermFunctor`. +-- This is the dual of `TranslateFunctor`. public export -TreeFunctor' : (Type -> Type) -> Type -> (Type -> Type) -TreeFunctor' f a = ProductF (ConstF a) f +ScaleFunctor' : (Type -> Type) -> Type -> (Type -> Type) +ScaleFunctor' f a = ProductF (ConstF a) f export -Functor f => Bifunctor (TreeFunctor' f) where +Functor f => Bifunctor (ScaleFunctor' f) where bimap f' g' (x, fx) = (f' x, map g' fx) -- The free monad of the identity functor. @@ -7167,7 +7417,7 @@ Subst0TypeF = CoproductFL Subst0TypeFCases public export Subst0TypeLimitIter : Type -> Type -Subst0TypeLimitIter = LimitIterF Subst0TypeF +Subst0TypeLimitIter = TrEitherF Subst0TypeF public export Subst0TypeColimitIter : Type -> Type @@ -7201,8 +7451,8 @@ CofreeSubst0Type = CofreeComonad Subst0TypeF public export subst0TypeCata : ParamCata Subst0TypeF subst0TypeCata v a subst alg (InFree x) = case x of - TermVar var => subst var - TermComposite com => alg $ case com of + TFV var => subst var + TFC com => alg $ case com of -- Unit Left () => Left () Right com' => Right $ case com' of @@ -7234,21 +7484,21 @@ interpretSubst0Alg = CoproductAlgL {l=Subst0TypeFCases} public export Subst0Unit : FreeSubst0Type carrier -Subst0Unit = inFreeComposite $ Left () +Subst0Unit = inFC $ Left () public export Subst0Void : FreeSubst0Type carrier -Subst0Void = inFreeComposite $ Right $ Left () +Subst0Void = inFC $ Right $ Left () public export Subst0Product : FreeSubst0Type carrier -> FreeSubst0Type carrier -> FreeSubst0Type carrier -Subst0Product a b = inFreeComposite $ Right $ Right $ Left (a, b) +Subst0Product a b = inFC $ Right $ Right $ Left (a, b) public export Subst0Coproduct : FreeSubst0Type carrier -> FreeSubst0Type carrier -> FreeSubst0Type carrier -Subst0Coproduct a b = inFreeComposite $ Right $ Right $ Right (a, b) +Subst0Coproduct a b = inFC $ Right $ Right $ Right (a, b) public export data Subst0MorphismF : diff --git a/geb-idris/src/Library/IdrisUtils.idr b/geb-idris/src/Library/IdrisUtils.idr index 7af86d2ba..e34c1d5e4 100644 --- a/geb-idris/src/Library/IdrisUtils.idr +++ b/geb-idris/src/Library/IdrisUtils.idr @@ -13,6 +13,7 @@ import public Data.Vect import public Data.Vect.Properties.Foldr import public Data.HVect import public Data.Fin +import public Data.Fin.Order import public Data.DPair import public Data.Bool import public Decidable.Decidable @@ -97,7 +98,8 @@ public export (Right x) >>= k = k x public export -fcong : {0 a, b : Type} -> {0 f, g : a -> b} -> (f = g) -> {x : a} -> f x = g x +fcong : {0 a, b : Type} -> {0 f, g : a -> b} -> + (f ~=~ g) -> {x : a} -> f x = g x fcong Refl = Refl export @@ -340,6 +342,20 @@ public export IsNothingTrue : {a : Type} -> Maybe a -> Type IsNothingTrue x = isJust x = False +public export +fromIsTrueNat : (m, n : Nat) -> m == n = True -> m = n +fromIsTrueNat 0 0 Refl = Refl +fromIsTrueNat 0 (S n) Refl impossible +fromIsTrueNat (S m) 0 Refl impossible +fromIsTrueNat (S m) (S n) eq = cong S $ fromIsTrueNat m n eq + +public export +fromIsTrueMaybeNat : (m, n : Maybe Nat) -> m == n = True -> m = n +fromIsTrueMaybeNat Nothing Nothing Refl = Refl +fromIsTrueMaybeNat Nothing (Just n) Refl impossible +fromIsTrueMaybeNat (Just m) Nothing Refl impossible +fromIsTrueMaybeNat (Just m) (Just n) eq = cong Just $ fromIsTrueNat m n eq + public export andLeft : {p, q : Bool} -> IsTrue (p && q) -> IsTrue p andLeft {p=True} {q=True} Refl = Refl @@ -354,6 +370,40 @@ andRight {p=True} {q=False} Refl impossible andRight {p=False} {q=True} Refl impossible andRight {p=False} {q=False} Refl impossible +public export +andBoth : {p, q : Bool} -> IsTrue p -> IsTrue q -> IsTrue (p && q) +andBoth {p=True} {q=True} Refl Refl = Refl +andBoth {p=True} {q=False} Refl Refl impossible +andBoth {p=False} {q=True} Refl Refl impossible +andBoth {p=False} {q=False} Refl Refl impossible + +public export +foldTrueInit : (b : Bool) -> (bs : List Bool) -> + foldl (\x, y => x && Delay y) b bs = True -> b = True +foldTrueInit b [] eq = eq +foldTrueInit b (b' :: bs) eq = andLeft $ foldTrueInit (b && b') bs eq + +public export +foldTrueList : (b : Bool) -> (bs : List Bool) -> + foldl (\x, y => x && Delay y) b bs = True -> all Prelude.id bs = True +foldTrueList b [] eq = Refl +foldTrueList b (b' :: bs) eq with (andRight (foldTrueInit (b && b') bs eq)) + foldTrueList b (True :: bs) eq | Refl = + let al = andLeft (foldTrueInit (b && True) bs eq) in + replace {p=(\b'' => foldl (\x, y => x && Delay y) b'' (True :: bs) = True)} + (andLeft (foldTrueInit (b && True) bs eq)) eq + +public export +foldTrueBoth : (b : Bool) -> (bs : List Bool) -> + b = True -> all Prelude.id bs = True -> + foldl (\x, y => x && Delay y) b bs = True +foldTrueBoth b [] beq bseq = beq +foldTrueBoth b (b' :: bs) beq bseq = + let fti = foldTrueInit b' bs bseq in + foldTrueBoth (b && b') bs + (rewrite beq in fti) + (replace {p=(\b'' => all id (b'' :: bs) = True)} fti bseq) + public export repeatIdx : {0 x : Type} -> (Nat -> x -> x) -> Nat -> Nat -> x -> x repeatIdx f Z i e = e @@ -690,6 +740,15 @@ equalNatCorrect : {m : Nat} -> equalNat m m = True equalNatCorrect {m=Z} = Refl equalNatCorrect {m=(S m')} = equalNatCorrect {m=m'} +public export +toIsTrueNat : (m, n : Nat) -> m = n -> m == n = True +toIsTrueNat m m Refl = equalNatCorrect {m} + +public export +toIsTrueMaybeNat : (m, n : Maybe Nat) -> m = n -> m == n = True +toIsTrueMaybeNat Nothing Nothing Refl = Refl +toIsTrueMaybeNat (Just m) (Just m) Refl = equalNatCorrect {m} + public export foldAppendExtensional : {0 a : Type} -> {n : Nat} -> (l : List a) -> (v : Vect n a) -> @@ -1017,6 +1076,70 @@ FinVoidDecoder : FinDecoder Void 0 FinVoidDecoder FZ impossible FinVoidDecoder (FS _) impossible +public export +FinVoidEncoder : FinEncoder FinVoidDecoder +FinVoidEncoder i = void i + +public export +FinVoidDecEncoding : FinDecEncoding Void 0 +FinVoidDecEncoding = (FinVoidDecoder ** FinVoidEncoder) + +public export +FinUnitDecoder : FinDecoder Unit 1 +FinUnitDecoder FZ = () + +public export +FinUnitEncoder : FinEncoder FinUnitDecoder +FinUnitEncoder () = (FZ ** Refl) + +public export +FinUnitDecEncoding : FinDecEncoding Unit 1 +FinUnitDecEncoding = (FinUnitDecoder ** FinUnitEncoder) + +public export +FinSumDecoder : {m, n : Nat} -> {ty, ty' : Type} -> + FinDecoder ty m -> FinDecoder ty' n -> FinDecoder (Either ty ty') (m + n) +FinSumDecoder {m} {n} {ty} {ty'} fde fde' i with (finToNat i) proof prf + FinSumDecoder {m} {n} {ty} {ty'} fde fde' i | idx with (isLT idx m) + FinSumDecoder {m} {n} {ty} {ty'} fde fde' i | idx | Yes islt = + Left $ fde $ natToFinLT {n=m} idx + FinSumDecoder {m} {n} {ty} {ty'} fde fde' i | idx | No isgte = + Right $ fde' $ + let islte : LTE (S (minus idx m)) n = ?FinSumDecoder_islte_hole in + natToFinLT {n} (minus idx m) + +public export +FinSumEncoder : {m, n : Nat} -> {ty, ty' : Type} -> + {dec : FinDecoder ty m} -> {dec' : FinDecoder ty' n} -> + (enc : FinEncoder {a=ty} {size=m} dec) -> + (enc' : FinEncoder {a=ty'} {size=n} dec') -> + NatEncoder (FinSumDecoder {m} {n} {ty} {ty'} dec dec') +FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Left e) with (enc e) proof eqe + FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Left _) | (ence ** Refl) + with (finToNat ence) proof eqf + FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Left _) | (ence ** Refl) | + idx = + (finToNat ence ** + ?finSumEncoder_hole_left_islte ** + ?finSumEncoder_hole_left_isinv) +FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Right e') with (enc' e') proof eqe + FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Right _) | (ence' ** Refl) + with (finToNat ence') proof eqf + FinSumEncoder {m} {n} {dec} {dec'} enc enc' (Right _) | (ence' ** Refl) | + idx = + (m + finToNat ence' ** + ?finSumEncoder_hole_right_islte ** + ?finSumEncoder_hole_right_isinv) + +public export +FinSumDecEncoding : {m, n : Nat} -> {ty, ty' : Type} -> + {dec : FinDecoder ty m} -> {dec' : FinDecoder ty' n} -> + (enc : FinEncoder {a=ty} {size=m} dec) -> + (enc' : FinEncoder {a=ty'} {size=n} dec') -> + FinDecEncoding (Either ty ty') (m + n) +FinSumDecEncoding {dec} {dec'} enc enc' = + NatDecEncoding (FinSumDecoder dec dec') (FinSumEncoder enc enc') + public export FinIdDecoder : (size : Nat) -> FinDecoder (Fin size) size FinIdDecoder size = id @@ -1025,18 +1148,10 @@ public export FinIdEncoder : (size : Nat) -> FinEncoder (FinIdDecoder size) FinIdEncoder size i = (i ** Refl) -public export -FinVoidEncoder : FinEncoder FinVoidDecoder -FinVoidEncoder i = void i - public export FinIdDecEncoding : (size : Nat) -> FinDecEncoding (Fin size) size FinIdDecEncoding size = (FinIdDecoder size ** FinIdEncoder size) -public export -FinVoidDecEncoding : FinDecEncoding Void 0 -FinVoidDecEncoding = (FinVoidDecoder ** FinVoidEncoder) - public export FDEnc : Type -> Type FDEnc = DPair Nat . FinDecEncoding @@ -1045,6 +1160,60 @@ public export fdeSize : {0 a : Type} -> FDEnc a -> Nat fdeSize = fst +public export +FinType : Type +FinType = DPair Type FDEnc + +public export +ftType : FinType -> Type +ftType = DPair.fst + +public export +ftEnc : (ft : FinType) -> FDEnc (ftType ft) +ftEnc = DPair.snd + +public export +ftSize : FinType -> Nat +ftSize ft = fdeSize (ftEnc ft) + +-- A pair of terms of a finite type. +public export +FTPair : FinType -> FinType -> Type +FTPair ft ft' = Pair (ftType ft) (ftType ft') + +-- A list of terms of a finite type. +public export +FTList : FinType -> Type +FTList ft = List (ftType ft) + +-- A vector of terms of a finite type. +public export +FTVect : Nat -> FinType -> Type +FTVect k ft = Vect k (ftType ft) + +-- A vector _indexed_ by a finite type -- that is, a tuple of elements +-- of some (other) type whose length is the size of the finite type. +-- The "I" is for "indexed". +public export +FTIVect : FinType -> Type -> Type +FTIVect ft t = Vect (ftSize ft) t + +-- A vector of types indexed by some finite type. +FTITyVect : FinType -> Type +FTITyVect ft = FTIVect ft Type + +-- An object of the slice category of `Type` over some `FinType`'s +-- underlying type (i.e. a finite type, or more explicitly, a type +-- with a finite number of terms). +public export +FSlice : FinType -> Type +FSlice ft = ftType ft -> Type + +-- A dependent list indexed by terms of a finite type. +public export +FHList : (ft : FinType) -> FTITyVect ft -> Type +FHList ft tys = HVect {k=(ftSize ft)} tys + public export ListContains : {a : Type} -> List a -> a -> Type ListContains [] x = Void @@ -1198,3 +1367,27 @@ BCPFalse = Left () public export BCPTrue : BoolCP BCPTrue = Right () + +public export +FS3CP : Type +FS3CP = Either Unit BoolCP + +public export +FS3CP0 : FS3CP +FS3CP0 = Left () + +public export +FS3CP1 : FS3CP +FS3CP1 = Right BCPFalse + +public export +FS3CP2 : FS3CP +FS3CP2 = Right BCPTrue + +public export +zipLen : {0 a, b, c : Type} -> (a -> b -> c) -> (l : List a) -> (l' : List b) -> + length l = length l' -> List c +zipLen f [] [] Refl = [] +zipLen f [] (x :: xs) Refl impossible +zipLen f (x :: xs) [] Refl impossible +zipLen f (x :: xs) (y :: ys) eq = f x y :: zipLen f xs ys (injective eq) diff --git a/geb.asd b/geb.asd index b3ac2fde3..d46ab4f00 100644 --- a/geb.asd +++ b/geb.asd @@ -5,7 +5,7 @@ :cl-reexport :mgl-pax :command-line-arguments) - :version "0.2.0" + :version "0.3.1" :description "Gödel, Escher, Bach, a categorical view of computation" :build-pathname "../build/geb.image" :entry-point "geb.entry::entry" @@ -37,9 +37,16 @@ :depends-on (util) :components ((:file package) (:file generics))) + (:module extensions + :serial t + :depends-on (specs util vampir) + :description "The Extensions module" + :components ((:file package) + (:file sub-expressions))) (:module vampir :serial t :description "The Vampir Extraction Module" + :depends-on (specs) :components ((:file package) (:file spec) (:file print) @@ -50,19 +57,23 @@ :depends-on (util specs) :components ((:file package) (:file geb) - (:file bool))) + (:file bool) + (:file list) + (:file trans))) (:module poly :serial t :description "Polynomial" - :depends-on (util geb vampir specs) + :depends-on (util geb vampir specs extensions) :components ((:file package) - (:file poly))) + (:file poly) + (:file trans))) (:module bitc :serial t :description "bitc (Boolean Circuits)" :depends-on (util vampir mixins specs) :components ((:file package) - (:file bitc))) + (:file bitc) + (:file trans))) (:module lambda :serial t :depends-on (geb specs) @@ -74,7 +85,8 @@ :components ((:file package) (:file lambda))) - (:file lambda))) + (:file lambda) + (:file trans))) (:module specs :serial t :depends-on (util mixins) @@ -85,6 +97,8 @@ (:file lambda) (:file poly) (:file poly-printer) + (:file extension) + (:file extension-printer) (:file bitc) (:file bitc-printer) ;; HACK: to make the package properly refer to the @@ -94,14 +108,6 @@ ;; !IMPORTANT! ;; All trans files go here, as they rely on other trans files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (:module trans - :description "All the trans modules so they can all know about the - other transformation functions before we compile them!" - :pathname "../src/" - :components ((:file lambda/trans) - (:file geb/trans) - (:file poly/trans) - (:file bitc/trans))) (:module entry :serial t :description "Entry point for the geb codebase" @@ -141,11 +147,14 @@ ((:file package) (:file meta) (:file geb) + (:file geb-trans) (:file lambda) - (:file lambda-conversion) + (:file lambda-experimental) + (:file lambda-trans) (:file poly) (:file bitc) (:file pipeline) + (:file list) (:module gui :serial t :components ((:file test) diff --git a/src/bitc/package.lisp b/src/bitc/package.lisp index 9386522b5..1236ea41a 100644 --- a/src/bitc/package.lisp +++ b/src/bitc/package.lisp @@ -15,15 +15,15 @@ (pax:defsection @bitc-trans (:title "Bits (Boolean Circuit) Transformations") "This covers transformation functions from" (to-circuit (pax:method () ( t))) - (to-vampir (pax:method () (compose t))) - (to-vampir (pax:method () (fork t))) - (to-vampir (pax:method () (parallel t))) - (to-vampir (pax:method () (swap t))) - (to-vampir (pax:method () (one t))) - (to-vampir (pax:method () (zero t))) - (to-vampir (pax:method () (ident t))) - (to-vampir (pax:method () (drop t))) - (to-vampir (pax:method () (branch t)))) + (to-vampir (pax:method () (compose t t))) + (to-vampir (pax:method () (fork t t))) + (to-vampir (pax:method () (parallel t t))) + (to-vampir (pax:method () (swap t t))) + (to-vampir (pax:method () (one t t))) + (to-vampir (pax:method () (zero t t))) + (to-vampir (pax:method () (ident t t))) + (to-vampir (pax:method () (drop t t))) + (to-vampir (pax:method () (branch t t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; bitc module diff --git a/src/bitc/trans.lisp b/src/bitc/trans.lisp index 0d49a9d46..ceba9941e 100644 --- a/src/bitc/trans.lisp +++ b/src/bitc/trans.lisp @@ -6,15 +6,17 @@ (wires (loop for i from 1 to wire-count collect (vamp:make-wire :var (intern (format nil "x~a" i) :keyword))))) - (vamp:make-alias :name name - :inputs wires - :body (list (vamp:make-tuples :wires (to-vampir morphism wires)))))) + (list + (vamp:make-alias :name name + :inputs wires + :body (list (vamp:make-tuples :wires (to-vampir morphism wires nil))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Bits to Vampir Implementation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod to-vampir ((obj ) values) +(defmethod to-vampir ((obj ) values constraints) + (declare (ignore constraints)) (declare (ignore values)) (subclass-responsibility obj)) @@ -23,15 +25,17 @@ :lhs value1 :rhs value2)) -(defmethod to-vampir ((obj compose) values) +(defmethod to-vampir ((obj compose) values constraints) (to-vampir (mcar obj) - (to-vampir (mcadr obj) values))) + (to-vampir (mcadr obj) values constraints) + constraints)) -(defmethod to-vampir ((obj fork) values) +(defmethod to-vampir ((obj fork) values constraints) "Copy input n intput bits into 2*n output bits" + (declare (ignore constraints)) (append values values)) -(defmethod to-vampir ((obj parallel) values) +(defmethod to-vampir ((obj parallel) values constraints) "Take n + m bits, execute car the n bits and cadr on the m bits and concat the results from car and cadr" (let* ((car (mcar obj)) @@ -39,35 +43,37 @@ (cx (dom car)) (inp1 (subseq values 0 cx)) (inp2 (subseq values cx))) - (append (to-vampir car inp1) - (to-vampir cadr inp2)))) + (append (to-vampir car inp1 constraints) + (to-vampir cadr inp2 constraints)))) -(defmethod to-vampir ((obj swap) values) +(defmethod to-vampir ((obj swap) values constraints) "Turn n + m bits into m + n bits by swapping" + (declare (ignore constraints)) (let ((n (mcar obj))) (append (subseq values n) (subseq values 0 n)))) -(defmethod to-vampir ((obj one) values) +(defmethod to-vampir ((obj one) values constraints) "Produce a bitvector of length 1 containing 1" - (declare (ignore values)) + (declare (ignore values constraints)) (list (vamp:make-constant :const 1))) -(defmethod to-vampir ((obj zero) values) +(defmethod to-vampir ((obj zero) values constraints) "Produce a bitvector of length 1 containing 0" - (declare (ignore values)) + (declare (ignore values constraints)) (list (vamp:make-constant :const 0))) -(defmethod to-vampir ((obj ident) values) +(defmethod to-vampir ((obj ident) values constraints) + (declare (ignore constraints)) "turn n bits into n bits by doing nothing" values) -(defmethod to-vampir ((obj drop) values) +(defmethod to-vampir ((obj drop) values constraints) "turn n bits into an empty bitvector" - (declare (ignore values)) + (declare (ignore values constraints)) nil) -(defmethod to-vampir ((obj branch) values) +(defmethod to-vampir ((obj branch) values constraints) "Look at the first bit. If its 0, run f on the remaining bits. @@ -82,5 +88,5 @@ (infix-creation :+ (infix-creation :* (infix-creation :- one x) f-elem) (infix-creation :* x g-elem))) - (to-vampir f xs) - (to-vampir g xs)))) + (to-vampir f xs constraints) + (to-vampir g xs constraints)))) diff --git a/src/entry/entry.lisp b/src/entry/entry.lisp index b1eb1d7b6..295d3989c 100644 --- a/src/entry/entry.lisp +++ b/src/entry/entry.lisp @@ -45,21 +45,11 @@ (eval (eval name)) (vampir-name (renaming-scheme (intern (symbol-name name) 'keyword)))) (cond ((and vampir stlc) - (geb.vampir:extract - (list - (lambda:to-circuit nil - (lambda:typed-stlc-type eval) - (lambda:typed-stlc-value eval) - vampir-name)) - stream)) + (geb.vampir:extract (to-circuit eval vampir-name) stream)) (stlc - (format stream - "~A" - (lambda:compile-checked-term nil - (lambda:typed-stlc-type eval) - (lambda:typed-stlc-value eval)))) + (format stream "~A" (to-cat nil eval))) (vampir - (geb.vampir:extract (list (to-circuit eval vampir-name)))) + (geb.vampir:extract (to-circuit eval vampir-name))) (t (format stream eval))))) diff --git a/src/entry/package.lisp b/src/entry/package.lisp index 375ddf34c..80f3edf6a 100644 --- a/src/entry/package.lisp +++ b/src/entry/package.lisp @@ -26,13 +26,13 @@ to use An example use of this binary is as follows ```bash -mariari@Gensokyo % ./geb.image -i \"foo.lisp\" -e \"geb.lambda.spec::*entry*\" -l -v -o \"foo.pir\" +mariari@Gensokyo % ./geb.image -i \"foo.lisp\" -e \"geb.lambda.main::*entry*\" -l -v -o \"foo.pir\" mariari@Gensokyo % cat foo.pir -def *entry* x { - 0 -}% -mariari@Gensokyo % ./geb.image -i \"foo.lisp\" -e \"geb.lambda.spec::*entry*\" -l -v +def entry x1 = { + (x1) +};% +mariari@Gensokyo % ./geb.image -i \"foo.lisp\" -e \"geb.lambda.main::*entry*\" -l -v def *entry* x { 0 } @@ -50,11 +50,18 @@ def *entry* x { starting from a file *foo.lisp* that has +any valid lambda form. Good examples can be found at the following section: + +[GEB.LAMBDA:@STLC][pax:section] + +with the term bound to some global variable + ```lisp -(in-package :geb.lambda.spec) +(in-package :geb.lambda.main) (defparameter *entry* - (typed unit geb:so1)) + (lamb (list (coprod so1 so1)) + (index 0))) ``` inside of it. diff --git a/src/extensions/package.lisp b/src/extensions/package.lisp new file mode 100644 index 000000000..f0e076483 --- /dev/null +++ b/src/extensions/package.lisp @@ -0,0 +1,17 @@ +(geb.utils:muffle-package-variance + (uiop:define-package #:geb.extensions + (:documentation "Special algorithms for extensions") + (:mix #:common-lisp #:geb.utils #:geb.extension.spec #:geb.mixins #:serapeum))) + +(in-package :geb.extensions) + +(pax:defsection @extensions (:title "Geb Extension API") + "Here we cover features entailed by the extensions." + + (@sub-expressions pax:document)) + +(pax:defsection @sub-expressions (:title "Sub Expression API") + "Here we cover functions regarding common sub-expressions" + (keep-unique pax:function) + (compute-common-usages pax:function) + (common-sub-expressions pax:function)) diff --git a/src/extensions/sub-expressions.lisp b/src/extensions/sub-expressions.lisp new file mode 100644 index 000000000..3660fbbe3 --- /dev/null +++ b/src/extensions/sub-expressions.lisp @@ -0,0 +1,68 @@ +(in-package :geb.extensions) + +(deftype obj-morph () `(or cat-obj cat-morph t)) + +(-> can-continuep (t) boolean) +(defun can-continuep (term) + (and (or (typep term 'pointwise-mixin) + (typep term 'list)) + (not (typep term 'cat-obj)) + (not (typep term 'number)) + (not (typep term 'string)) + (not (typep term 'geb.vampir.spec:constant)))) + +(-> common-sub-expressions (obj-morph) (values obj-morph fset:map)) +(defun common-sub-expressions (term) + "Compute common sub-expressions and return an object with the +appropriate sub-expressions uniquely identified" + (if (can-continuep term) + (keep-unique term (compute-common-usages term)) + (values term (fset:empty-map)))) + +(-> compute-common-usages (obj-morph) fset:bag) +(defun compute-common-usages (obj) + ;; we are going to be smart about this + ;; no manual recursion, we don't need that + (labels ((reduce-fn (bag term) + (cond ((not (can-continuep term)) + bag) + ;; we don't want to actually add + ;; to a total that is already + ;; count + ((fset:member? term bag) + (fset:with bag term)) + (t + (recursive (fset:with bag term) term)))) + (recursive (bag term) + (if (listp term) + (reduce #'reduce-fn term :initial-value bag) + (reduce-pointwise #'reduce-fn term bag)))) + (values + (fset:filter-pairs (lambda (x y) (declare (ignore x)) (<= 2 y)) + (recursive (fset:empty-bag) obj))))) + +(-> keep-unique (obj-morph fset:bag) (values obj-morph fset:map)) +(defun keep-unique (obj bag) + "given a BAG and an term, mark each term which appears in the bag as a +[COMMON-SUB-EXPRESSION][type]. + +We also return the map of names that each common expression is had, +for further processing. + +This is part two of the COMMON-SUB-EXPRESSIONS pass." + (let ((mapping (fset:image (lambda (x y) + (declare (ignore y)) + (values x (gensym))) + (fset:convert 'fset:map bag)))) + (labels ((recursive (obj) + (if (not (can-continuep obj)) + (values obj mapping) + (let ((looked (fset:lookup mapping obj)) + (new-obj + (if (listp obj) + (mapcar #'recursive obj) + (map-pointwise #'recursive obj)))) + (if looked + (make-common-sub-expression :obj new-obj :name looked) + new-obj))))) + (values (recursive obj) mapping)))) diff --git a/src/geb/geb.lisp b/src/geb/geb.lisp index fa5a34c57..c30ab6028 100644 --- a/src/geb/geb.lisp +++ b/src/geb/geb.lisp @@ -12,7 +12,7 @@ (prod (curry (curry (prod-left-assoc fun)))))) (defmethod dom ((x )) - (assure substobj + (assure cat-obj (typecase-of substmorph x (init so0) (terminal (obj x)) @@ -29,8 +29,14 @@ (otherwise (subclass-responsibility x))))) +(defmethod dom ((ref reference)) + ref) + +(defmethod codom ((ref reference)) + ref) + (defmethod codom ((x )) - (assure substobj + (assure cat-obj (typecase-of substmorph x (terminal so1) (init (obj x)) @@ -69,7 +75,7 @@ then: (const f x) : a → b (const f x) : a → b ``` -Further, If the input `F` is an [ALIAS][type], then we wrap the output +Further, If the input `F` has an ALIAS, then we wrap the output in a new alias to denote it's a constant version of that value. @@ -106,7 +112,7 @@ Example: "swap the input [domain][DOM] of the given [cat-morph] In order to swap the [domain][DOM] we expect the [cat-morph] to -be a [PROD][type] +be a [PROD][class] Thus if: `(dom morph) ≡ (prod x y)`, for any `x`, `y` [CAT-OBJ] @@ -219,6 +225,24 @@ u (_ (error "object ~A need to be of a coproduct type, however it is of ~A" f (dom f))))) +(defun coprod-mor (f g) + "Given f : A → B and g : C → D gives appropriate morphism between +[COPROD][class] objects f x g : A + B → C + D via the unversal property. +That is, the morphism part of the coproduct functor Geb x Geb → Geb" + (mcase (comp (->left (codom f) (codom g)) + f) + (comp (->right (codom f) (codom g)) + g))) + +(defun prod-mor (f g) + "Given f : A → B and g : C → D gives appropriate morphism between +[PROD][class] objects f x g : A x B → C x D via the unversal property. +This is the morphism part of the product functor Geb x Geb → Geb" + (pair (comp f + (<-left (dom f) (dom g))) + (comp g + (<-right (dom f) (dom g))))) + (defgeneric text-name (morph) (:documentation "Gets the name of the moprhism")) @@ -237,13 +261,38 @@ u (substobj "Id") (otherwise (subclass-responsibility morph)))) +(defmethod text-name ((morph opaque-morph)) + "") +(defmethod text-name ((morph cat-obj)) + "Id") + +(defmethod maybe ((obj )) + "I recursively add maybe terms to all [\\][class] terms, +for what maybe means checkout [my generic function documentation][maybe]. + +turning [products][prod] of A x B into Maybe (Maybe A x Maybe B), + +turning [coproducts][coprod] of A | B into Maybe (Maybe A | Maybe B), + +turning [SO1] into Maybe [SO1] + +and [SO0] into Maybe [SO0]" + (typecase-of substobj obj + (so0 (coprod so1 so0)) + (so1 (coprod so1 so1)) + (coprod (coprod so1 (coprod (maybe (mcar obj)) + (maybe (mcadr obj))))) + (prod (coprod so1 (prod (maybe (mcar obj)) + (maybe (mcadr obj))))) + (otherwise (subclass-responsibility obj)))) + (defun curry (f) -"Curries the given object, returns a [cat-morph] + "Curries the given object, returns a [cat-morph] -The [cat-morph] given must have its DOM be of a PROD type, as [CURRY][generic-function] +The [cat-morph] given must have its DOM be of a PROD type, as [CURRY][function] invokes the idea of -if f : ([PROD][TYPE] a b) → c +if f : ([PROD][class] a b) → c for all `a`, `b`, and `c` being an element of [cat-morph] @@ -266,6 +315,17 @@ In category terms, `a → c^b` is isomorphic to `a → b → c` (let ((dom (dom f))) (curry-prod f (mcar dom) (mcadr dom))))) +(defun uncurry (y z f) + "Given a morphism f : x → z^y and explicitly given y and z variables +produces an uncurried version f' : x × y → z of said morphism" + (comp (so-eval y z) + (pair (comp f (<-left (dom f) y)) (<-right (dom f) y)))) + +(defun morph-type (f) + "Given a moprhism f : a → b gives a list (a, b) of the domain and +codomain respectively" + (list (dom f) (codom f))) + (defmethod gapply ((morph ) object) "My main documentation can be found on [GAPPLY][generic-function] @@ -345,3 +405,31 @@ GEB> (gapply geb-bool:and (cadr object))))) (substobj object) (otherwise (subclass-responsibility morph)))) + +;; I believe this is the correct way to use gapply for cat-obj +(defmethod gapply ((morph cat-obj) object) + "My main documentation can be found on [GAPPLY][generic-function] + +I am the [GAPPLY][generic-function] for a generic [CAT-OBJ][class]. I +simply return the object given to me" + object) + +(defmethod gapply ((morph opaque-morph) object) + "My main documentation can be found on [GAPPLY][generic-function] + +I am the [GAPPLY][generic-function] for a generic [OPAQUE-MOPRH][class] +I simply dispatch [GAPPLY][generic-function] on my interior code +```lisp +GEB> (gapply (comp geb-list:*car* geb-list:*cons*) + (list (right geb-bool:true-obj) (left geb-list:*nil*))) +(right GEB-BOOL:TRUE) +```" + (gapply (code morph) object)) + +(defmethod gapply ((morph opaque) object) + "My main documentation can be found on [GAPPLY][generic-function] + +I am the [GAPPLY][generic-function] for a generic [OPAQUE][class] I +simply dispatch [GAPPLY][generic-function] on my interior code, which +is likely just an object" + (gapply (code morph) object)) diff --git a/src/geb/list.lisp b/src/geb/list.lisp new file mode 100644 index 000000000..5464f3e6b --- /dev/null +++ b/src/geb/list.lisp @@ -0,0 +1,67 @@ +(in-package :geb-list) + +(defparameter *nil* (alias nil (so1))) + +(defparameter *cons-type* (reference 'cons)) + +(defparameter *list* + (alias list + (coprod *nil* *cons-type*))) + +;; we should register this somewhere for checking if we care +(defparameter *canonical-cons-type* + (opaque 'cons + (prod geb-bool:bool *list*))) + +(defparameter *cons* + (alias cons-μ + (opaque-morph (prod geb-bool:bool *list*) + :codom *cons-type*))) + +(defparameter *car* + (alias car + (opaque-morph (<-left geb-bool:bool *list*) + :dom *cons-type*))) + +(defparameter *cdr* + (alias cdr + (opaque-morph (<-right geb-bool:bool *list*) + :dom *cons-type*))) + +(def cons->list + (->right *nil* *cons-type*)) + +(def nil->list + (->left *nil* *cons-type*)) + +(defun cons-on-list (terminal-morphism) + "Cons an element onto a list, assuming our value can be created from +[SO1][class]" + (comp *cons* (pair (comp terminal-morphism (terminal *list*)) + *list*))) + + +;; let the optimizer handle this +(defun cons-on-nil (terminal-morphism) + "Cons an element onto a nil, assuming our value can be created from +[SO1][class]" + (comp (cons-on-list terminal-morphism) + nil->list)) + +;; let the optimizer handle this +(defun cons-on-cons (terminal-morphism) + "Cons an element onto a cons, assuming our value can be created from +[SO1][class]" + (comp (cons-on-list terminal-morphism) + cons->list)) + +(def silly-example + (comp (mcase nil->list + (comp cons->list (cons-on-cons geb-bool:true))) + cons->list *cons*)) + +(def silly-example-cdring + (comp (cons-on-cons geb-bool:false) + (mcase (cons-on-nil geb-bool:true) + *cons-type*) + *cdr* (cons-on-list geb-bool:true) *cdr*)) diff --git a/src/geb/package.lisp b/src/geb/package.lisp index f27be78d1..bde4b8647 100644 --- a/src/geb/package.lisp +++ b/src/geb/package.lisp @@ -5,7 +5,7 @@ (geb.utils:muffle-package-variance (defpackage #:geb.main (:documentation "Gödel, Escher, Bach categorical model") - (:use #:common-lisp #:geb.generics #:serapeum #:geb.mixins #:geb.utils #:geb.spec) + (:use #:common-lisp #:geb.generics #:geb.extension.spec #:serapeum #:geb.mixins #:geb.utils #:geb.spec) (:local-nicknames (#:poly #:geb.poly.spec) (#:bitc #:geb.bitc.spec)) (:shadowing-import-from #:geb.spec :left :right :prod :case) (:export :prod :case :mcar :mcadr :mcaddr :mcdr :name :func :obj :dom :codom))) @@ -26,7 +26,13 @@ (so-card-alg pax:generic-function) (so-card-alg (pax:method () ())) (curry pax:function) - (text-name pax:generic-function)) + (coprod-mor pax:function) + (prod-mor pax:function) + (uncurry pax:function) + (text-name pax:generic-function) + + "These utilities are ontop of [CAT-OBJ]" + (maybe (pax:method () ()))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Standard Library throughout the codebase @@ -37,7 +43,7 @@ (:documentation "Provides the standard library for any GEB code") (:shadowing-import-from #:geb.spec :left :right :prod :case) (:import-from #:trivia #:match) - (:use-reexport #:geb.mixins #:geb.generics #:geb.spec #:geb.main #:geb.utils + (:use-reexport #:geb.mixins #:geb.generics #:geb.extension.spec #:geb.spec #:geb.main #:geb.utils #:serapeum #:common-lisp))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -105,6 +111,49 @@ The functions given work on this." (or pax:symbol-macro)) +(geb.utils:muffle-package-variance + (uiop:define-package #:geb-list + (:documentation "Defines out booleans for the geb language") + (:use #:geb.common))) + +(in-package #:geb-list) + +(pax:defsection @geb-list (:title "Lists") + "Here we define out the idea of a List. It comes naturally from the +concept of coproducts. Since we lack polymorphism this list is +concrete over [GEB-BOOL:@GEB-BOOL][section] In ML syntax it looks like + +```haskell +data List = Nil | Cons Bool List +``` + +We likewise define it with coproducts, with the recursive type being opaque + +```lisp +(defparameter *nil* (so1)) + +(defparameter *cons-type* (reference 'cons)) + +(defparameter *canonical-cons-type* + (opaque 'cons + (prod geb-bool:bool *cons-type*))) + +(defparameter *list* + (coprod *nil* *cons-type*)) +``` + +The functions given work on this." + (*nil* pax:variable) + (*cons-type* pax:variable) + (*list* pax:variable) + (*car* pax:variable) + (*cons* pax:variable) + (*cdr* pax:variable) + (cons->list pax:symbol-macro) + (nil->list pax:symbol-macro) + (*canonical-cons-type* pax:variable)) + + (geb.utils:muffle-package-variance (uiop:define-package #:geb (:documentation "Gödel, Escher, Bach categorical model") @@ -127,7 +176,10 @@ The functions given work on this." (pax:defsection @geb-api (:title "API") "Various forms and structures built on-top of @GEB-CATEGORIES" (gapply (pax:method () ( t))) + (gapply (pax:method () (opaque-morph t))) + (gapply (pax:method () (opaque t))) (geb-bool::@geb-bool pax:section) + (geb-list::@geb-list pax:section) (geb.trans:@geb-translation pax:section) (@geb-utility pax:section)) @@ -145,3 +197,14 @@ The functions given work on this." (+ 1 2 3 4) => 10 ```") + + +(geb.utils:muffle-package-variance + (uiop:define-package #:geb-tri + (:documentation "Defines out booleans for the geb language") + (:mix #:geb.main #:geb.spec #:serapeum #:common-lisp) + (:shadow :false :true :not :and :or :no) + (:export + :bool :fasle :true :not :and :or))) + +(in-package #:geb-tri) diff --git a/src/geb/trans.lisp b/src/geb/trans.lisp index db1a4e3fd..9bdaef78f 100644 --- a/src/geb/trans.lisp +++ b/src/geb/trans.lisp @@ -32,7 +32,13 @@ (project-left (let ((nat (obj-to-nat (mcar obj)))) (if (zerop nat) nat - (poly:/ poly:ident nat)))) + ;; we want to bitshift it by the size + (poly:/ + (poly:- poly:ident + ;; we need to remove the right value + ;; we are doing project-right + (to-poly (<-right (mcar obj) (mcadr obj)))) + nat)))) (distribute (let ((cx (obj-to-nat (mcar obj))) (cy (obj-to-nat (mcadr obj))) (cz (obj-to-nat (mcaddr obj)))) @@ -48,8 +54,8 @@ (poly:* cx cy))))))) (pair (let* ((z (codom (mcdr obj))) (cz (obj-to-nat z))) - (poly:* cz (poly:+ (to-poly (mcar obj)) - (to-poly (mcdr obj)))))) + (poly:+ (poly:* cz (to-poly (mcar obj))) + (to-poly (mcdr obj))))) (case (let* ((f (mcar obj)) (x (dom f)) (cx (obj-to-nat x)) @@ -72,8 +78,7 @@ (defmethod to-circuit ((obj ) name) "Turns a @GEB-SUBSTMORPH to a Vamp-IR Term" - (assure geb.vampir.spec:statement - (to-circuit (to-poly obj) name))) + (to-circuit (to-bitc obj) name)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Morph to Bitc Implementation @@ -97,7 +102,11 @@ ;; This should never occure, but if it does, it produces a ;; constant morphism onto an all 0s list (init - (apply #'bitc:parallel (zero-list (bitwidth (mcar obj))))) + (let* ((list (zero-list (bitwidth (mcar obj)))) + (len (length list))) + (cond ((= 0 len) (bitc:drop 0)) + ((= 1 len) bitc:zero) + (t (apply #'bitc:parallel list))))) ;; Terminal maps any bit-list onto the empty bit-list (terminal (bitc:drop (bitwidth (mcar obj)))) @@ -111,7 +120,7 @@ (apply #'bitc:parallel (append (list bitc:zero (bitc:ident car-width)) (zero-list (padding-bits cadr-width - car-width)))))) + car-width)))))) ;; Inject-right y -> x + y tags the y with a 1, indicating right, ;; and pads the encoded y with as many zeros as would be needed ;; to store either an x or a y. @@ -121,7 +130,7 @@ (apply #'bitc:parallel (append (list bitc:one (bitc:ident cadr-width)) (zero-list (padding-bits car-width - cadr-width)))))) + cadr-width)))))) ;; Case translates directly into a branch. The sub-morphisms of ;; case are padded with drop so they have the same input lengths. diff --git a/src/geb/tri.lisp b/src/geb/tri.lisp new file mode 100644 index 000000000..56fa313d3 --- /dev/null +++ b/src/geb/tri.lisp @@ -0,0 +1,52 @@ +(in-package :geb-tri) + + +(def yes (alias yes (so1))) +(def no (alias no (so1))) +(def maybe (alias maybe (so1))) + +(def inj-maybe (alias inj-maybe (comp + (->right yes (coprod no maybe)) + (->right no maybe)))) +(def inj-no (alias inj-no (comp + (->right yes (coprod no maybe)) + (->left no maybe)))) + +(def inj-yes (alias inj-yes (->left yes (coprod no maybe)))) + +(def decision + (alias decision (coprod yes (coprod no maybe)))) + + +;; for now +(defun distrib (obj1 obj2) + (distribute obj1 (mcar obj2) (mcadr obj2))) + +;; implement mega-case instead of working with mcase +;; (defun mega-case ()) + +;; make mega-distribute as well, it's a pain + +(def demote + (alias demote + (mcase (const inj-maybe yes) + (const inj-no (coprod no maybe))))) + +(def promote + (alias promote + (mcase inj-yes + (mcase (const inj-maybe no) + (const inj-yes maybe))))) + +(def merge-opinion + (alias merge-opinion + (comp + (mcase (comp promote + (<-left decision yes)) + ;; no + maybe + (comp + (mcase (comp demote + (<-left decision no)) + (<-left decision maybe)) + (distribute decision no maybe))) + (distrib decision decision)))) diff --git a/src/generics/generics.lisp b/src/generics/generics.lisp index 02d72e50c..3d79bbb8a 100644 --- a/src/generics/generics.lisp +++ b/src/generics/generics.lisp @@ -23,6 +23,25 @@ GEB> (gapply (comp (left s-1) ```")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Object Functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defgeneric maybe (object) + (:documentation + "Wraps the given OBJECT into a Maybe monad The Maybe monad in this +case is simply wrapping the term in a [coprod][geb.spec:coprod] +of [so1][geb.spec:so1] + +``` lisp +;; Before +x + +;; After +(COPROD SO1 X) +```")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Conversion functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -40,7 +59,7 @@ GEB> (gapply (comp "Turns a MORPHISM into a Vampir circuit. the NAME is the given name of the output circuit.")) -(defgeneric to-vampir (morphism values) +(defgeneric to-vampir (morphism values constraints) (:documentation "Turns a MORPHISM into a Vampir circuit, with concrete values. @@ -48,4 +67,10 @@ The more natural interface is [TO-CIRCUIT], however this is a more low level interface into what the polynomial categories actually implement, and thus can be extended or changed. -The VALUES are likely vampir values in a list.")) +The VALUES are likely vampir values in a list. + +The CONSTRAINTS represent constraints that get creating")) + +(defgeneric to-cat (context term) + (:documentation + "Turns a MORPHISM with a context into Geb's Core category")) diff --git a/src/generics/package.lisp b/src/generics/package.lisp index f53b2628b..db520b679 100644 --- a/src/generics/package.lisp +++ b/src/generics/package.lisp @@ -13,7 +13,9 @@ You can view their documentation in their respective API sections. The main documentation for the functionality is given here, with examples often given in the specific methods" (gapply pax:generic-function) + (maybe pax:generic-function) (to-circuit pax:generic-function) (to-bitc pax:generic-function) (to-poly pax:generic-function) + (to-cat pax:generic-function) (to-vampir pax:generic-function)) diff --git a/src/gui/graphing/core.lisp b/src/gui/graphing/core.lisp index f67f30f3e..f18e065c1 100644 --- a/src/gui/graphing/core.lisp +++ b/src/gui/graphing/core.lisp @@ -1,5 +1,9 @@ (in-package #:geb-gui.core) +(defgeneric representation (object)) +(defgeneric children (object)) +(defgeneric value (object)) + (deftype note () "A note is a note about a new node in the graph or a note about a NODE which should be merged into an upcoming NODE. @@ -115,26 +119,13 @@ to be merged")) (make-instance 'node :representation morph :value morph) notes)) (name (meta-lookup morph :alias))) - (with-slots (value) node - (setf value (make-alias :name name :obj value)) - node))) + (name-node node name))) ((has-aliasp morph) - (let ((node-codom (make-note :from morph - :note (symbol-name (meta-lookup morph :alias)) - :value (graphize (codom morph) notes))) - ;; TODO :: Replace me with the full (obj morph) instead. - (node (make-squash :value (graphize (dom morph) nil)))) - (apply-note node node-codom) - (value node))) + (alias-moprh morph notes)) (t (typecase-of substmorph morph ((or terminal init distribute inject-left inject-right project-left project-right) - ;; Since there is no note in this case, this - ;; representation will serve as the note as to - ;; how we should annotate the arrow. - (make-instance 'node :representation morph - :value (dom morph) - :children (list (graphize (codom morph) notes)))) + (dom-codom-graph morph notes)) (substobj (continue-graphizing (make-instance 'node :representation morph :value morph) notes)) @@ -185,6 +176,38 @@ to be merged")) (otherwise (geb.utils:subclass-responsibility morph))))))) +(defmethod graphize ((ref geb.common:reference) notes) + (name-node (continue-graphizing + (make-instance 'node :representation ref :value ref) + notes) + (name ref))) + +(defmethod graphize ((opaque geb.common:opaque-morph) notes) + (if (has-aliasp opaque) + (alias-moprh opaque notes) + (dom-codom-graph opaque notes))) + +(defmethod graphize ((opaque geb.common:opaque) notes) + (continue-graphizing (make-instance 'node :representation opaque :value opaque) + notes)) + +(defun alias-moprh (morph notes) + (let ((node-codom (make-note :from morph + :note (symbol-name (meta-lookup morph :alias)) + :value (graphize (codom morph) notes))) + ;; TODO :: Replace me with the full (obj morph) instead. + (node (make-squash :value (graphize (dom morph) nil)))) + (apply-note node node-codom) + (value node))) + +(defun dom-codom-graph (morph notes) + "We simply take the dom and codom and graph it" + ;; Since there is no note in this case, this + ;; representation will serve as the note as to + ;; how we should annotate the arrow. + (make-instance 'node :representation morph + :value (dom morph) + :children (list (graphize (codom morph) notes)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; cutting a node @@ -335,3 +358,12 @@ as that is the proper NODE to continue from" (or (meta-lookup from to) (list (geb:text-name (representation from)) (representation from)))) + +(defun name-node (node name) + (with-slots (value) node + (if (eql nil name) + ;; hack + (setf value (make-alias :name (intern (symbol-name name) 'keyword) + :obj (shallow-copy-object value))) + (setf value (make-alias :name name :obj (shallow-copy-object value)))) + node)) diff --git a/src/gui/graphing/package.lisp b/src/gui/graphing/package.lisp index 971441511..68d9cfbb1 100644 --- a/src/gui/graphing/package.lisp +++ b/src/gui/graphing/package.lisp @@ -12,6 +12,8 @@ object into a format for a graphing backend." "The core types that facilittate the functionality" (note pax:type) (node pax:class) + (node-note pax:class) + (squash-note pax:class) (make-note pax:function) (make-squash pax:function) (graphize pax:generic-function) diff --git a/src/gui/gui.lisp b/src/gui/gui.lisp index 485b82daf..5b22bd32e 100644 --- a/src/gui/gui.lisp +++ b/src/gui/gui.lisp @@ -61,7 +61,11 @@ ((graph-p frame) (display-graph frame pane)) (t - (present-object (root frame) pane)))) + (handler-case (present-object (root frame) pane) + (error (c) + (declare (ignore c)) + (format pane "issue displaying, please call swap to get it back into a graph~%") + (display-graph frame pane)))))) (defun display-graph (frame pane) (apply (if (dot-p frame) diff --git a/src/gui/package.lisp b/src/gui/package.lisp index 224a77471..f99b3a5dd 100644 --- a/src/gui/package.lisp +++ b/src/gui/package.lisp @@ -25,5 +25,5 @@ layout of the term, showing what kind of data " (pax:defsection @visaulizer-aid (:title "Aiding the Visualizer") "One can aid the visualization process a bit, this can be done by -simply playing [GEB:ALIAS][type] around the object, this will place it +simply placing ALIAS around the object, this will place it in a box with a name to better identify it in the graphing procedure.") diff --git a/src/gui/show-view.lisp b/src/gui/show-view.lisp index 37bd78302..e5184fcc7 100644 --- a/src/gui/show-view.lisp +++ b/src/gui/show-view.lisp @@ -16,9 +16,10 @@ (defmacro with-presenting-alias ((obj pane) &body otherwise) "Presents an alias if it exists, otherwise" - (let ((alias (gensym))) - `(let ((,alias (geb.mixins:meta-lookup ,obj :alias))) - (if ,alias + (let ((alias (gensym)) + (in-there (gensym))) + `(multiple-value-bind (,alias ,in-there) (geb.mixins:meta-lookup ,obj :alias) + (if ,in-there (surrounding-output-with-border (,pane :shape :rectangle :background +alice-blue+) (formatting-table (,pane) (formatting-row (,pane) @@ -270,3 +271,14 @@ (view show-view) &key) (format stream object)) + +(define-presentation-method present ((object geb.common:reference) + (type geb.common:reference) + (pane extended-output-stream) + (view show-view) + &key) + (surrounding-output-with-border (pane :shape :rectangle :background +alice-blue+) + (formatting-table (pane) + (formatting-row (pane) + (formatting-cell (pane) + (format pane "~W" (intern (symbol-name (geb.utils:name object))))))))) diff --git a/src/lambda/lambda.lisp b/src/lambda/lambda.lisp index 7828d2d93..8f0de2fba 100644 --- a/src/lambda/lambda.lisp +++ b/src/lambda/lambda.lisp @@ -1 +1,334 @@ -(in-package #:geb.lambda) +(in-package #:geb.lambda.main) + +(defclass fun-type (geb.mixins:direct-pointwise-mixin geb.mixins:cat-obj) + ((mcar :initarg :mcar + :accessor mcar + :documentation "") + (mcadr :initarg :mcadr + :accessor mcadr + :documentation "")) + (:documentation + "Stand-in for the [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] object. It does not have +any computational properties and can be seen as just a function of two arguments +with accessors [MCAR][generic-function] to the first argument and +[MCADR][generic-function] to the second argument. There is an evident canonical +way to associate [FUN-TYPE][class] and [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] +pointwise.")) + +(defun fun-type (mcar mcadr) + (make-instance 'fun-type :mcar mcar :mcadr mcadr)) + +(defmethod maybe ((object fun-type)) + "I recursively add maybe terms to my domain and codomain, and even +return a maybe function. Thus if the original function was + +``` +f : a -> b +``` + +we would now be + +``` +f : maybe (maybe a -> maybe b) +``` + +for what maybe means checkout [my generic function documentation][maybe]." + (coprod so1 + (fun-type (maybe (mcar object)) + (maybe (mcadr object))))) + +;; Below we list all possible ways of getting a term of the exponential, +;; namely: projections, casing, absurd, lambda-abstraction and application + +;; Problem: this covers only canonical costructors, might need to +;; further extend the definition + +(defun hom-cod (ctx f) + "Given a context of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with occurences of +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by [FUN-TYPE][class], and similarly +an [STLC][type] term of the stand-in for the hom object, produces the stand-in +to the codomain." + (let ((rec (ann-term1 ctx f))) + (cond ((typep f 'fst) (let ((tt (term f))) + (if (typep tt 'pair) + (hom-cod ctx (ltm tt)) + (hom-cod ctx tt)))) + ((typep f 'snd) (let ((tt (term f))) + (if (typep tt 'pair) + (hom-cod ctx (rtm tt)) + (hom-cod ctx tt)))) + ((typep f 'case-on) (hom-cod + (cons (mcar (ttype (ann-term1 ctx (on f)))) + ctx) + (ltm f))) + ((typep f 'absurd) (hom-cod ctx (term f))) + ((typep f 'lamb) (mcadr (ttype rec))) + ((typep f 'app) (hom-cod ctx (fun f))) + ((typep f 'index) (mcadr (ttype rec))) + ((typep f 'err) (mcadr (ttype f))) + (t (error "not a valid STLC exponential term"))))) + +(-> index-check (fixnum list) cat-obj) +(defun index-check (i ctx) + "Given an natural number I and a context, checks that the context is of +length at least I and then produces the Ith entry of the context counted +from the left starting with 0." + (let ((l (length ctx))) + (if (< i l) + (nth i ctx) + (error "Argument exceeds length of context")))) + +;; Types all terms inside a given lambda term with respect to a context +;; with the caveat of producing a stand-in of the exponential object + +;; We assume that the compiler receives all the info using the exp-aux +;; class instead of the usual hom-obj for the well-defp predicate + + +(defgeneric ann-term1 (ctx tterm) + (:documentation + "Given a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] objects with +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] occurences replaced by [FUN-TYPE][class] +and an [STLC][type] similarly replacing type occurences of the hom object +to [FUN-TYPE][class], provides the [TTYPE][generic-function] accessor to all +subterms as well as the term itself, using [FUN-TYPE][class]. Once again, +note that it is important for the context and term to be giving as +per above description. While not always, not doing so result in an error upon +evaluation. As an example of a valid entry we have + +```lisp + (ann-term1 (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) +``` + +while + +```lisp +(ann-term1 (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) +``` + +produces an error trying to use [HOM-COD]. This warning applies to other +functions taking in context and terms below as well. + +Moreover, note that for terms whose typing needs addition of new context +we append contexts on the left rather than on the right contra usual type +theoretic notation for the convenience of computation. That means, e.g. that +asking for a type of a lambda term as below produces: + +```lisp +LAMBDA> (ttype (term (ann-term1 (lambda (list so1 so0) (index 0))))) +s-1 +``` + +as we count indeces from the left of the context while appending new types to +the context on the left as well. For more info check [LAMB][class]")) + + +(defmethod ann-term1 (ctx (tterm )) + ;; cahce check + (if (ttype tterm) + tterm + (match-of stlc tterm + ((absurd tcod term) (absurd tcod (ann-term1 ctx term) :ttype tcod)) + (unit (unit :ttype so1)) + ((left rty term) (let ((lant (ann-term1 ctx term))) + (left rty + lant + :ttype (coprod (ttype lant) rty)))) + ((right lty term) (let ((rant (ann-term1 ctx term))) + (right lty + rant + :ttype (coprod lty (ttype rant))))) + ((pair ltm rtm) (let ((lant (ann-term1 ctx ltm)) + (rant (ann-term1 ctx rtm))) + (pair lant + rant + :ttype (prod (ttype lant) (ttype rant))))) + ((fst term) (let* ((ann-term (ann-term1 ctx term)) + (type-of-term (ttype (ann-term1 ctx term)))) + (if (typep type-of-term 'prod) + (fst ann-term + :ttype (mcar type-of-term)) + (error "type of term not of product type")))) + ((snd term) (let* ((ann-term (ann-term1 ctx term)) + (type-of-term (ttype ann-term))) + (if (typep type-of-term 'prod) + (snd ann-term :ttype (mcadr type-of-term)) + (error "type of term not of product type")))) + ((lamb tdom term) (let ((ant (ann-term1 (append tdom ctx) term))) + (lamb tdom + ant + :ttype (fun-type (reduce #'prod tdom) (ttype ant))))) + ((app fun term) (app (ann-term1 ctx fun) + (mapcar (lambda (trm) (ann-term1 ctx trm)) term) + :ttype (hom-cod ctx fun))) + ((index pos) (index pos + :ttype (index-check pos ctx))) + ((err ttype) (err ttype)) + ((case-on on ltm rtm) + (let* ((ann-on (ann-term1 ctx on)) + (type-of-on (ttype ann-on)) + (ann-left (ann-term1 (cons (mcar type-of-on) ctx) ltm)) + (ann-right (ann-term1 (cons (mcadr type-of-on) ctx) rtm))) + (if (typep type-of-on 'coprod) + (case-on ann-on ann-left ann-right :ttype (ttype ann-left)) + (error "type of on not of coproduct type"))))))) + +;; Changes the stand in Geb term with exponential stand-ins +;; to one containing actual hom-objects +(defun fun-to-hom (t1) + "Given a [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] whose subobjects might have a +[FUN-TYPE][class] occurence replaces all occurences of [FUN-TYPE][class] with a +suitable [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ], hence giving a pure +[SUBSTOBJ][GEB.SPEC:SUBSTOBJ] + +```lisp +LAMBDA> (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)) +(× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) +```" + (cond ((typep t1 'prod) (prod (fun-to-hom (mcar t1)) + (fun-to-hom (mcadr t1)))) + ((typep t1 'coprod) (coprod (fun-to-hom (mcar t1)) + (fun-to-hom (mcadr t1)))) + ((typep t1 'fun-type) (so-hom-obj (fun-to-hom (mcar t1)) + (fun-to-hom (mcadr t1)))) + (t t1))) + +;; Changes all annotated terms' types to actual Geb objects + +(defun ann-term2 (tterm) + "Given an [STLC][type] term with a [TTYPE][generic-function] accessor from +[ANN-TERM1][generic-function] - i.e. including possible [FUN-TYPE][class] +occurences - re-annotates the term and its subterms with actual +[SUBSTOBJ][GEB.SPEC:SUBSTOBJ] objects." + (match-of stlc tterm + ((absurd tcod term) (absurd (fun-to-hom tcod) + (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + (unit tterm) + ((right lty term) (right (fun-to-hom lty) + (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((left rty term) (left (fun-to-hom rty) + (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((case-on on ltm rtm) (case-on (ann-term2 on) + (ann-term2 ltm) + (ann-term2 rtm) + :ttype (fun-to-hom (ttype tterm)))) + ((pair ltm rtm) (pair (ann-term2 ltm) + (ann-term2 rtm) + :ttype (fun-to-hom (ttype tterm)))) + ((fst term) (fst (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((snd term) (snd (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((lamb tdom term) (lamb (mapcar #'fun-to-hom tdom) + (ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((app fun term) (app (ann-term2 fun) + (mapcar #'ann-term2 term) + :ttype (fun-to-hom (ttype tterm)))) + ((index pos) (index pos + :ttype (fun-to-hom (ttype tterm)))) + ((err ttype) (err (fun-to-hom ttype))))) + +(defun annotated-term (ctx term) + "Given a context consisting of a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] +with occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by +[FUN-TYPE][class] and an [STLC][type] term with similarly replaced occurences +of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ], provides an [STLC][type] with all +subterms typed, i.e. providing the [TTYPE][generic-function] accessor, +which is a pure [SUBSTOBJ][GEB.SPEC:SUBSTOBJ]" + (ann-term2 (ann-term1 ctx term))) + + +;; Produces a type of a lambda term in a context +;; with a stand-in for the exponential object + +(defun type-of-term-w-fun (ctx tterm) + "Given a context consisting of a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with +occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by [FUN-TYPE][class] +and an [STLC][type] term with similarly replaced occurences of +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ], gives out a type of the whole term with +occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by [FUN-TYPE][class]." + (ttype (ann-term1 ctx tterm))) + +;; Actual type info + +(defun type-of-term (ctx tterm) + "Given a context consisting of a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with +occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by [FUN-TYPE][class] +and an [STLC][type] term with similarly replaced occurences of +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ], provides the type of the whole term, +which is a pure [SUBSTOBJ][type]." + (fun-to-hom (type-of-term-w-fun ctx tterm))) + +;;Predicate checking that a term in a given context is well-typed + +(defgeneric well-defp (ctx tterm) + (:documentation + "Given a context consisting of a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] +with occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by +[FUN-TYPE][class] and an [STLC][type] term with similarly replaced +occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ], checks that the term +is well-defined in the context based on structural rules of simply +typed lambda calculus. returns the t if it is, otherwise returning +nil")) + +(defmethod well-defp (ctx (tterm )) + (labels ((check (tterm) + (match-of stlc tterm + ((absurd) + (and (check (term tterm)) + (obj-equalp (ttype (term tterm)) so0))) + ((left term) + (and (check term) + (obj-equalp (mcar (ttype tterm)) (ttype term)))) + ((right term) + (and (check term) + (obj-equalp (mcadr (ttype tterm)) (ttype term)))) + ((pair ltm rtm) + (and (check ltm) + (check rtm))) + ((fst term) + (and (check term) + (obj-equalp (ttype tterm) (mcar (ttype term))))) + ((snd term) + (and (check term) + (obj-equalp (ttype tterm) (mcadr (ttype term))))) + ((case-on on ltm rtm) + (and (check ltm) + (check rtm) + (check on) + (obj-equalp (ttype ltm) (ttype rtm)))) + ((lamb tdom term) + (let ((lambda-type (ttype tterm))) + (and (check term) + (obj-equalp (mcar lambda-type) (reduce #'prod tdom)) + (obj-equalp (mcadr lambda-type) (ttype term))))) + ((app fun term) + (and (check fun) + (check (reduce #'pair term)))) + (index t) + (unit t) + (err t)))) + (let ((term (ignore-errors + (ann-term1 ctx tterm)))) + (and term (check term))))) + +(defun errorp (tterm) + "Evaluates to true iff the term has an error subterm." + (cond ((or (typep tterm 'index) + (typep tterm 'unit)) nil) + ((typep tterm 'err) t) + ((typep tterm 'case-on) (or (errorp (on tterm)) + (errorp (rtm tterm)) + (errorp (ltm tterm)))) + ((typep tterm 'pair) (or (errorp (ltm tterm)) + (errorp (rtm tterm)))) + ((typep tterm 'app) (or (errorp (fun tterm)) + (some #'identity + (mapcar + (lambda (x) (errorp x)) + (term tterm))))) + (t (errorp (term tterm))))) diff --git a/src/lambda/package.lisp b/src/lambda/package.lisp index 033c62cdd..bfd36b00a 100644 --- a/src/lambda/package.lisp +++ b/src/lambda/package.lisp @@ -13,7 +13,25 @@ (in-package #:geb.lambda.main) (pax:defsection @lambda-api (:title "Main functionality") - "This covers the main API for the STLC module") + "This covers the main API for the STLC module" + + (ann-term1 pax:generic-function) + (hom-cod pax:function) + (index-check pax:function) + (fun-to-hom pax:function) + (ann-term2 pax:function) + (annotated-term pax:function) + (type-of-term-w-fun pax:function) + (type-of-term pax:function) + (well-defp pax:generic-function) + (fun-type pax:class) + (fun-type pax:function) + (errorp pax:function) + + (mcar (pax:method () (fun-type))) + (mcadr (pax:method () (fun-type))) + + (maybe (pax:method () (fun-type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; trans module @@ -24,7 +42,6 @@ (geb.utils:muffle-package-variance (uiop:define-package #:geb.lambda.trans (:documentation "A basic lambda translator into other parts of geb") - (:shadow #:to-poly #:to-circuit) (:mix #:geb.lambda.spec #:geb.common #:common-lisp :geb.lambda.main))) (in-package #:geb.lambda.trans) @@ -37,10 +54,18 @@ (pax:defsection @stlc-conversion (:title "Transition Functions") "These functions deal with transforming the data structure to other data types" - (compile-checked-term pax:generic-function) - (to-poly pax:function) - (to-circuit pax:function) - (@utility pax:section)) + + "One important note about the lambda conversions is that all +transition functions except [TO-CAT] do not take a context. + +Thus if the [\\] term contains free variables, then call +[TO-CAT] and give it the desired context before calling +any other transition functions" + (to-cat (pax:method () (t ))) + (to-poly (pax:method () ())) + (to-bitc (pax:method () ())) + (to-circuit (pax:method () ( t))) + (@utility pax:section)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lambda module @@ -57,7 +82,74 @@ data types" (in-package #:geb.lambda) (pax:defsection @stlc (:title "The Simply Typed Lambda Calculus model") - "This covers GEB's view on simply typed lambda calculus" + "This covers GEB's view on simply typed lambda calculus + +This serves as a useful frontend for those wishing to write a compiler +to GEB and do not wish to target the categorical model. + +If one is targeting their compiler to the frontend, then the following +code should be useful for you. + +```lisp +(in-package :geb.lambda.main) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (index 0)) + :id) +(def id x1 = { + (x1) + };) + +MAIN> +(to-circuit + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit))))) + :not) +(def not x1 = { + (((1 - x1) * 1) + (x1 * 0), ((1 - x1) * 1) + (x1 * 0)) + };) + +MAIN> (to-circuit (lamb (list geb-bool:bool) + (left so1 (right so1 (index 0)))) :foo) +(def foo x1 = { + (0, 1, x1) + };) +``` + +For testing purposes, it may be useful to go to the `BITC` backend and +run our interpreter + + +```lisp +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*1) +#*00 +MAIN> +(gapply (to-bitc + (lamb (list (coprod so1 so1)) + (case-on (index 0) + (lamb (list so1) + (right so1 (unit))) + (lamb (list so1) + (left so1 (unit)))))) + #*0) +#*11 +``` + +" (@lambda-specs pax:section) (@lambda-api pax:section) (@stlc-conversion pax:section)) diff --git a/src/lambda/trans.lisp b/src/lambda/trans.lisp index f97c793de..d128e1ed2 100644 --- a/src/lambda/trans.lisp +++ b/src/lambda/trans.lisp @@ -8,83 +8,403 @@ ;; Main Transformers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric compile-checked-term (context type term) - (:documentation "Compiles a checked term into SubstMorph category")) - -(-> to-poly (list t ) (or geb.poly: geb.poly:poly)) -(defun to-poly (context type obj) - (assure (or geb.poly: geb.poly:poly) - (~>> obj - (compile-checked-term context type) - geb.common:to-poly))) - -(-> to-circuit (list t keyword) geb.vampir.spec:statement) -(defun to-circuit (context type obj name) - (assure geb.vampir.spec:statement - (~> (to-poly context type obj) +(defmethod to-bitc ((obj )) + "I convert a lambda term into a [GEB.BITC.SPEC:BITC] term + +Note that [\\] terms with free variables require a context, +and we do not supply them here to conform to the standard interface + +If you want to give a context, please call [to-cat] before +calling me" + (~>> obj + (to-cat nil) + geb.common:to-bitc)) + +(defmethod to-poly ((obj )) + "I convert a lambda term into a [GEB.POLY.SPEC:POLY] term + +Note that [\\] terms with free variables require a context, +and we do not supply them here to conform to the standard interface + +If you want to give a context, please call [to-cat] before +calling me" + (~>> obj + (to-cat nil) + geb.common:to-poly)) + +(defmethod to-circuit ((obj ) name) + "I convert a lambda term into a vampir term + +Note that [\\] terms with free variables require a context, +and we do not supply them here to conform to the standard interface + +If you want to give a context, please call [to-cat] before +calling me" + (assure list + (~> (to-bitc obj) (geb.common:to-circuit name)))) (defmethod empty ((class (eql (find-class 'list)))) nil) -(defmethod compile-checked-term (context type (term )) - (assure - (match-of stlc term - ((absurd type v) - (comp (init type) - (compile-checked-term context so0 v))) - (unit - (terminal (stlc-ctx-to-mu context))) - ((left lty rty term) - lty rty - (assert (typep type 'coprod) nil "invalid lambda type to left ~A" type) - (comp (->left (mcar type) (mcadr type)) - (compile-checked-term context (mcar type) term))) - ((right lty rty term) - lty rty - (assert (typep type 'coprod) nil "invalid lambda type to right ~A" type) - (comp (->right (mcar type) (mcadr type)) - (compile-checked-term context (mcar type) term))) - ((case-on lty rty cod on l r) - (comp (mcase (curry (compile-checked-term (cons lty context) cod l)) - (curry (compile-checked-term (cons rty context) cod r))) - (compile-checked-term context (coprod lty rty) on))) - ((pair lty rty l r) - (geb:pair (compile-checked-term context lty l) - (compile-checked-term context rty r))) - ((fst lty rty value) - (assert (geb.mixins:obj-equalp (class-of lty) (class-of type)) - nil - "Types should match on fst: ~A ~A" - term - type) - (comp (<-left lty rty) (compile-checked-term context (prod lty rty) value))) - ((snd lty rty value) - (assert (geb.mixins:obj-equalp (class-of rty) (class-of type)) - nil - "Types should match on fst: ~A ~A" - term - type) - (comp (<-right lty rty) (compile-checked-term context (prod lty rty) value))) - ((lamb vty tty term) - (curry (commutes-left - (compile-checked-term (cons vty context) tty term)))) - ((app dom com f x) - (assert (geb.mixins:obj-equalp dom type) - nil - "Types should match for application: ~A ~A" - dom - type) - (comp - (so-eval dom com) - (geb:pair (compile-checked-term context dom f) - (compile-checked-term context com x)))) - ((index i) - (stlc-ctx-proj context i))))) +(defmethod to-cat (context (tterm )) + "Compiles a checked term in said context to a Geb morphism. If the term has +an instance of an erorr term, wraps it in a Maybe monad, otherwise, compiles +according to the term model interpretation of STLC" + (if (errorp tterm) + (to-cat-err context tterm) + (to-cat-cor context tterm))) + +(defun maybe-comp (ob) + "Takes a [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with possible fun-type instances +and removes them" + (fun-to-hom (maybe ob))) + +(defun maybe-rest (ob) + "Takes a Geb object wrapped in Maybe and gives out the part without the +error node" + (mcadr (maybe-comp ob))) + +(defmethod to-cat-err (context (tterm )) + "Compiles a checked term with an error term in an appropriate context into the +morphism of the GEB category using a Maybe monad wrapper, that is, given a +context G and a term t of type A produces a morphism with domain +(stlc-ctx-maybe context) and codomain (maybe A). + +Terms come from [STLC][type] with occurences of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] +replaced by [FUN-TYPE][class] and should come without the slow of +[TTYPE][generic-function] accessor filled for any of the subterms. Context should +be a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with the caveat that instead of +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] we ought to use [FUN-TYPE][class], a stand-in +for the internal hom object with explicit accessors to the domain and the +codomain. Once again, note that it is important for the context and term to be +giving as per above description. While not always, not doing so result in an +error upon evaluation. As an example of a valid entry we have + +```lisp + (to-cat-err (list so1 (fun-type so1 so1)) (app (index 1) (list (error so1)))) +``` + +while + +```lisp +(to-cat-err (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (error so1)))) +``` + +produces an error. Error of such kind mind pop up both on the level of evaluating +[WELL-DEFP][generic-function] and [ANN-TERM1][generic-function]. + +Moreover, note that for terms whose typing needs addition of new context +we append contexts on the left rather than on the right contra usual type +theoretic notation for the convenience of computation. That means, e.g. that +asking for a type of a lambda term as below produces: + +```lisp +LAMBDA> (ttype (term (ann-term1 nil (lamb (list so1 so0) (index 0))))) +s-1 +``` + +as we count indeces from the left of the context while appending new types to +the context on the left as well. For more info check [LAMB][class] + +Note that the Maybe wrapper also applies to the context elements due to +functoriality concerns. Hence if one wanted to check the whether the term +(case-on (index 0) (err so1) (unit)) with a bool in contexts fails on the +left entry, one would need to evaluate + +```lisp +LAMBDA> (gapply (to-cat (list (coprod so1 so1)) + (case-on (index 0) + (err so1) + (unit))) + (list (geb:right (geb:left (geb:right so1))) so1)) +(left s-1) +``` + +and hence get an error part of the wrapper. While evaluating the right branch +will be done by: + +```lisp + LAMBDA> (gapply (to-cat (list (coprod so1 so1)) + (case-on (index 0) + (err so1) + (unit))) + (list (geb:right (geb:right (geb:right so1))) so1)) +(right s-1) +``` + +This follows from the fact that bool arapped in maybe is 1 + (bool + bool)" + (labels ((rec (context tterm) + (match-of stlc tterm + ((absurd tcod term) + (comp (mcase (->left so1 (maybe-rest tcod)) + (init (maybe-comp tcod))) + (rec context term))) + (unit + (comp (->right so1 so1) + (terminal (stlc-ctx-maybe context)))) + ((left rty term) + (comp (->right so1 (maybe-rest (ttype tterm))) + (comp (->left (maybe-comp (ttype term)) + (maybe-comp rty)) + (rec context term)))) + ((right lty term) + (comp (->right so1 (maybe-rest (ttype tterm))) + (comp (->right (maybe-comp lty) + (maybe-comp (ttype term))) + (rec context term)))) + ((case-on on ltm rtm) + (let ((mcartoon (mcar (ttype on))) + (mcadrtoon (mcadr (ttype on))) + (ctx (stlc-ctx-maybe context))) + (comp (mcase (comp (->left so1 (maybe-rest (ttype tterm))) + (terminal (prod ctx so1))) + (comp (mcase (commutes-left + (rec + (cons mcartoon + context) + ltm)) + (commutes-left + (rec + (cons mcadrtoon + context) + rtm))) + (distribute ctx + (maybe-comp mcartoon) + (maybe-comp mcadrtoon)))) + (comp (distribute ctx + so1 + (maybe-rest (coprod mcartoon + mcadrtoon))) + (geb:pair ctx (rec context on)))))) + ((pair ltm rtm) + (let ((lty (ttype ltm)) + (rty (ttype rtm))) + (comp (->right so1 (prod (maybe-comp lty) + (maybe-comp rty))) + (geb:pair (rec context ltm) + (rec context rtm))))) + ((fst term) + (let ((mcarttot (mcar (ttype term)))) + (comp (mcase (->left so1 (maybe-rest mcarttot)) + (<-left (maybe-comp mcarttot) + (maybe (mcadr (ttype term))))) + (rec context term)))) + ((snd term) + (let ((mcadrttot (mcadr (ttype term)))) + (comp (mcase (->left so1 (maybe-rest mcadrttot)) + (<-right (maybe-comp (mcar (ttype term))) + (maybe-comp mcadrttot))) + (rec context term)))) + ((lamb tdom term) + (comp (->right so1 (maybe-rest (fun-to-hom (ttype tterm)))) + (apply-n (length tdom) + #'(lambda (x) (curry (commutes-left x))) + (rec (append + (mapcar #'maybe-comp tdom) + context) term)))) + ((app fun term) + (let ((tofun (ttype fun))) + (comp + (mcase (->left so1 (maybe-rest tofun)) + (commutes-left + (so-eval (maybe-comp (mcar tofun)) + (maybe-comp (mcadr tofun))))) + (comp (distribute (reduce #'prod + (mapcar #'maybe-comp term) + :from-end t) + so1 + (maybe-rest tofun)) + (geb:pair (reduce #'geb:pair + (mapcar #'(lambda (x) (rec context x)) term) + :from-end t) + (rec context + fun)))))) + ((index pos) + (stlc-ctx-proj (mapcar #'maybe context) pos)) + ((err ttype) + (comp (->left so1 (maybe-comp ttype)) + (terminal (stlc-ctx-maybe context))))))) + (if (not (well-defp context tterm)) + (error "not a well-defined ~A in said ~A" tterm context) + (rec context (ann-term1 context tterm))))) + + +(defmethod to-cat-cor (context (tterm )) + "Compiles a checked term in an appropriate context into the +morphism of the GEB category. In detail, it takes a context and a term with +following restrictions: Terms come from [STLC][type] with occurences of +[SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] replaced by [FUN-TYPE][class] and should +come without the slow of [TTYPE][generic-function] accessor filled for any of +the subterms. Context should be a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] with +the caveat that instead of [SO-HOM-OBJ][GEB.MAIN:SO-HOM-OBJ] we ought to use +[FUN-TYPE][class], a stand-in for the internal hom object with explicit +accessors to the domain and the codomain. Once again, note that it is important +for the context and term to be giving as per above description. While not +always, not doing so result in an error upon evaluation. As an example of a +valid entry we have + +```lisp + (to-cat-cor (list so1 (fun-type so1 so1)) (app (index 1) (list (index 0)))) +``` + +while + +```lisp +(to-cat-cor (list so1 (so-hom-obj so1 so1)) (app (index 1) (list (index 0)))) +``` + +produces an error. Error of such kind mind pop up both on the level of evaluating +[WELL-DEFP][generic-function] and [ANN-TERM1][generic-function]. + +Moreover, note that for terms whose typing needs addition of new context +we append contexts on the left rather than on the right contra usual type +theoretic notation for the convenience of computation. That means, e.g. that +asking for a type of a lambda term as below produces: + +```lisp +LAMBDA> (ttype (term (ann-term1 nil (lamb (list so1 so0) (index 0))))) +s-1 +``` + +as we count indeces from the left of the context while appending new types to +the context on the left as well. For more info check [LAMB][class] + +Finally, note that the compilation uncurries the final morphism. That is, +if the type of the term is an exponential object, [TO-CAT-COR] uncurries the +morphism in the Geb category instead producing a morphism into the domain +of the exponential from a corresponding product. If the exponential is +iterated, so is the uncurrying." + (labels ((rec (context tterm) + (match-of stlc tterm + ((absurd tcod term) + (comp (init tcod) + (rec context term))) + (unit + (terminal (stlc-ctx-to-mu context))) + ((left rty term) + (comp (->left (ttype term) rty) + (rec context term))) + ((right lty term) + (comp (->right lty (ttype term)) + (rec context term))) + ((case-on on ltm rtm) + (let ((mcartoon (mcar (ttype on))) + (mcadrtoon (mcadr (ttype on))) + (ctx (stlc-ctx-to-mu context))) + (comp (mcase (commutes-left (rec + (cons (fun-to-hom mcartoon) context) ltm)) + (commutes-left (rec + (cons (fun-to-hom mcadrtoon) context) rtm))) + (comp (distribute ctx mcartoon mcadrtoon) + (geb:pair ctx (rec context on)))))) + ((pair ltm rtm) + (geb:pair (rec context ltm) + (rec context rtm))) + ((fst term) + (let ((tottt (ttype term))) + (comp (<-left (mcar tottt) (mcadr tottt)) + (rec context term)))) + ((snd term) + (let ((tottt (ttype term))) + (comp (<-right (mcar tottt) (mcadr tottt)) + (to-cat context term)))) + ((lamb tdom term) + (apply-n (length tdom) + #'(lambda (x) (curry (commutes-left x))) + (rec (append tdom context) term))) + ((app fun term) + (let ((tofun (ttype fun))) + (comp + (so-eval (fun-to-hom (mcar tofun)) + (fun-to-hom (mcadr tofun))) + (geb:pair (rec context fun) + (reduce #'geb:pair + (mapcar #'(lambda (x) (rec context x)) term) + :from-end t))))) + ((index pos) + (stlc-ctx-proj context pos)) + (err + (error "Not meant for the compiler"))))) + (cond ((not (well-defp context tterm)) + (error "not a well-defined ~A in said ~A" tterm context)) + ((typep (type-of-term-w-fun context tterm) 'fun-type) + (fun-uncurry-prod (type-of-term-w-fun context tterm) + (rec context (ann-term1 context tterm)))) + (t + (rec context (ann-term1 context tterm)))))) + +(defun fun-depth (obj) + "Looks at how iterated a function type is with [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] +being 0 iterated looking at the [MCADR][generic-function]. E.g.: + +```lisp +TRANS> (fun-depth so1) +0 + +TRANS> (fun-depth (fun-type so1 so1)) +1 + +TRANS> (fun-depth (fun-type so1 (fun-type so1 so1))) +2 + +TRANS> (fun-depth (fun-type (fun-type so1 so1) so1)) +1 +```" + (if (not (typep obj 'fun-type)) + 0 + (1+ (fun-depth (mcadr obj))))) + +(defun fun-uncurry-prod (obj f) + "Takes a morphism f : X -> obj where obj is an iterated function type +represented in Geb as B^(A1 x ... x An) and uncurries it but looking at the +iteration as product to a morphism f' : (A1 x ... An) x X -> B. E.g: + +``lisp +TRANS> (fun-uncurry-prod (fun-type so1 (fun-type so1 so1)) (init so1)) +(∘ (∘ (∘ (<-left s-1 s-1) + ((∘ (<-left s-1 s-1) + ((<-left s-1 (× s-1 s-1)) + (∘ (<-left s-1 s-1) (<-right s-1 (× s-1 s-1))))) + (∘ (<-right s-1 s-1) (<-right s-1 (× s-1 s-1))))) + ((∘ (0-> s-1) (<-left s-0 (× s-1 s-1))) (<-right s-0 (× s-1 s-1)))) + ((<-right (× s-1 s-1) s-0) (<-left (× s-1 s-1) s-0))) + +TRANS> (dom (fun-uncurry-prod (fun-type so1 (fun-type so1 so1)) (init so1))) +(× (× s-1 s-1) s-0) + +TRANS> (codom (fun-uncurry-prod (fun-type so1 (fun-type so1 so1)) (init so1))) +s-1 +```" + (labels ((lst-mcar (num ob) + (if (= num 1) + (list (mcar ob)) + (cons (mcar (apply-n (1- num) #'mcadr ob)) + (lst-mcar (1- num) ob))))) + (commutes-left (uncurry (reduce #'prod + (lst-mcar (fun-depth obj) obj) + :from-end t) + (apply-n (fun-depth obj) #'mcadr obj) + f)))) (-> stlc-ctx-to-mu (stlc-context) substobj) (defun stlc-ctx-to-mu (context) - "Converts a generic [][type] context into a [SUBSTMORPH][type]" - (mvfoldr #'prod context so1)) + "Converts a generic [][type] context into a +[SUBSTMORPH][GEB.SPEC:SUBSTMORPH]. Note that usually contexts can be interpreted +in a category as a $\Sigma$-type$, which in a non-dependent setting gives us a +usual [PROD][class] + +```lisp +LAMBDA> (stlc-ctx-to-mu (list so1 (fun-to-hom (fun-type geb-bool:bool geb-bool:bool)))) +(× s-1 + (× (+ GEB-BOOL:FALSE GEB-BOOL:TRUE) (+ GEB-BOOL:FALSE GEB-BOOL:TRUE)) + s-1) +```" + (mvfoldr #'prod (mapcar #'fun-to-hom context) so1)) + +(defun stlc-ctx-maybe (context) + "Takes a context seen as product of appropriate [SUBSTOBJ][GEB.SPEC:SUBSTOBJ] +and iteratively applies Maybe to its elements." + (mvfoldr #'prod (mapcar (lambda (x) (maybe-comp x)) context) so1)) (-> so-hom (substobj substobj) (or t substobj)) (defun so-hom (dom cod) @@ -95,14 +415,35 @@ ;; Utility Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun stlc-ctx-proj (context depth) + "Given a context, we interpret it as a [PROD][class] object of appropriate +length with fibrations given by [PROD][class] projections." (if (zerop depth) - (<-left (car context) + (<-left (fun-to-hom (car context)) (stlc-ctx-to-mu (cdr context))) (comp (stlc-ctx-proj (cdr context) (1- depth)) - (<-right (car context) + (<-right (fun-to-hom (car context)) (stlc-ctx-to-mu (cdr context)))))) +(defun prod-rem (num obj) + "Given a product A0 x A1 x ... x An and a positive integer k gives a +corresponding composition of morphisms projecting to Ak x ... x An" + (if (= num 1) + (<-right (mcar obj) (mcadr obj)) + (comp (<-right (mcar (apply-n (- num 1) #'mcadr obj)) + (apply-n num #'mcadr obj)) + (prod-rem (1- num) obj)))) + +(defun prod-proj (num obj) + "Given a product A0 x ... x An and an integer k less than n gives a +corresponding composition of projection morphism to Ak" + (if (zerop num) + (<-left (mcar obj) (mcadr obj)) + (let ((codm (codom (prod-rem num obj)))) + (comp (<-left (mcar codm) codm) + (prod-rem num obj))))) + (defun index-to-projection (depth typ-a typ-b prod) (if (zerop depth) (comp (<-left typ-a typ-b) prod) diff --git a/src/mixins/meta.lisp b/src/mixins/meta.lisp index f11b98aa7..941278abb 100644 --- a/src/mixins/meta.lisp +++ b/src/mixins/meta.lisp @@ -26,11 +26,24 @@ The :weak keyword specifies if the pointer stored in the value is weak" (setf (gethash key hash) (if weak (tg:make-weak-pointer value) value)))) -(-> meta-lookup (meta-mixin t) t) +(-> meta-lookup (meta-mixin t) (values t boolean)) (defun meta-lookup (object key) "Lookups the requested key in the metadata table of the object. We look past weak pointers if they exist" (let ((table (gethash object (meta object)))) (when table - (let ((value (gethash key table))) - (if (tg:weak-pointer-p value) (tg:weak-pointer-value value) value))))) + (multiple-value-bind (value in-there) (gethash key table) + (values (if (tg:weak-pointer-p value) (tg:weak-pointer-value value) value) + in-there))))) + +;; We need a custom copy for the meta-object + +(defmethod geb.utils:copy-instance ((object meta-mixin) &rest initargs + &key &allow-other-keys) + (declare (ignorable initargs)) + (let ((new-object (call-next-method)) + (table (gethash object (meta object)))) + (when table + (setf (gethash new-object (meta object)) ; should point to the same table + table)) + new-object)) diff --git a/src/mixins/mixins.lisp b/src/mixins/mixins.lisp index 7fbc8aaf5..708aced75 100644 --- a/src/mixins/mixins.lisp +++ b/src/mixins/mixins.lisp @@ -66,3 +66,28 @@ ;; I should implement it for arrays as well! (defmethod obj-equalp ((obj1 t) (obj2 t)) (equalp obj1 obj2)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Fset comparisons +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod fset:compare ((x direct-pointwise-mixin) (y direct-pointwise-mixin)) + (fset:compare (to-pointwise-list x) + (to-pointwise-list y))) + +(-> map-pointwise (function pointwise-mixin) pointwise-mixin) +(defun map-pointwise (function obj) + (values + (apply #'util:copy-instance obj + (alexandria:alist-plist + (mapcar (lambda (x) + (cons (car x) + (funcall function (cdr x)))) + (to-pointwise-list obj)))))) + +(-> reduce-pointwise (function pointwise-mixin t) t) +(defun reduce-pointwise (function obj initial) + (reduce (lambda (x y) + (funcall function x (cdr y))) + (to-pointwise-list obj) + :initial-value initial)) diff --git a/src/mixins/package.lisp b/src/mixins/package.lisp index a2c63f5c9..dbc83d2b1 100644 --- a/src/mixins/package.lisp +++ b/src/mixins/package.lisp @@ -109,7 +109,9 @@ storage.") (to-pointwise-list pax:generic-function) (obj-equalp pax:generic-function) - (pointwise-slots pax:generic-function)) + (pointwise-slots pax:generic-function) + (map-pointwise pax:function) + (reduce-pointwise pax:function)) (defun my-transcript (fn) (let ((pax:*transcribe-check-consistency* diff --git a/src/poly/package.lisp b/src/poly/package.lisp index 84dcd21d3..22ed1d15e 100644 --- a/src/poly/package.lisp +++ b/src/poly/package.lisp @@ -6,7 +6,8 @@ (muffle-package-variance (defpackage #:geb.poly.trans - (:local-nicknames (:vamp :geb.vampir.spec)) + (:local-nicknames (:vamp :geb.vampir.spec) + (:ext :geb.extensions)) (:use #:geb.common #:geb.poly.spec) (:shadowing-import-from #:geb.poly.spec :+ :* :/ :- :mod))) @@ -15,16 +16,16 @@ (pax:defsection @poly-trans (:title "Polynomial Transformations") "This covers transformation functions from" (to-circuit (pax:method () ( t))) - (to-vampir (pax:method () (integer t))) - (to-vampir (pax:method () (ident t))) - (to-vampir (pax:method () (+ t))) - (to-vampir (pax:method () (* t))) - (to-vampir (pax:method () (- t))) - (to-vampir (pax:method () (/ t))) - (to-vampir (pax:method () (compose t))) - (to-vampir (pax:method () (if-zero t))) - (to-vampir (pax:method () (if-lt t))) - (to-vampir (pax:method () (mod t)))) + (to-vampir (pax:method () (integer t t))) + (to-vampir (pax:method () (ident t t))) + (to-vampir (pax:method () (+ t t))) + (to-vampir (pax:method () (* t t))) + (to-vampir (pax:method () (- t t))) + (to-vampir (pax:method () (/ t t))) + (to-vampir (pax:method () (compose t t))) + (to-vampir (pax:method () (if-zero t t))) + (to-vampir (pax:method () (if-lt t t))) + (to-vampir (pax:method () (mod t t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; poly module diff --git a/src/poly/poly.lisp b/src/poly/poly.lisp index c815bea73..9f63c4d6d 100644 --- a/src/poly/poly.lisp +++ b/src/poly/poly.lisp @@ -36,8 +36,8 @@ POLY> (gapply (- (* 2 ident ident) (* ident ident)) 5) (* (gapply (mcar morphism) object) (gapply (mcadr morphism) object))) (poly:/ - (/ (gapply (mcar morphism) object) - (gapply (mcadr morphism) object))) + (floor (gapply (mcar morphism) object) + (gapply (mcadr morphism) object))) (poly:- (- (gapply (mcar morphism) object) (gapply (mcadr morphism) object))) diff --git a/src/poly/trans.lisp b/src/poly/trans.lisp index e39288a8b..572280af2 100644 --- a/src/poly/trans.lisp +++ b/src/poly/trans.lisp @@ -10,10 +10,21 @@ returning the value" (circuit-gen morphism name)) (defun circuit-gen (morphism name) - (let ((wire (vamp:make-wire :var :x))) - (vamp:make-alias :name name - :inputs (list wire) - :body (list (to-vampir morphism wire))))) + "Turns a POLY term into a Vamp-IR Gate with the given name" + (labels ((make-alias (name morphism) + (let ((wire (vamp:make-wire :var :x))) + (multiple-value-bind (results lets) (to-vampir morphism wire nil) + (vamp:make-alias :name name + :inputs (list wire) + :body (reverse (cons results lets))))))) + (multiple-value-bind (morphism map) (ext:common-sub-expressions morphism) + (append (mapcar + (lambda (x) + (let ((term (car x)) + (name (cdr x))) + (make-alias name term))) + (fset:convert 'list map)) + (list (make-alias name morphism)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Poly to Vampir Implementation @@ -26,8 +37,8 @@ returning the value" ;; See geb:to-poly ;; ;; to see what that style of code is like as apposed to this. -(defmethod to-vampir ((obj ) value) - (declare (ignore value)) +(defmethod to-vampir ((obj ) value let-vars) + (declare (ignore value let-vars)) (subclass-responsibility obj)) (-> direct-fields-to-list-vampir (geb.mixins:direct-pointwise-mixin) list) @@ -38,62 +49,86 @@ returning the value" ;; evaluate to themselves but I'm unsure of how this works on an input ;; level -(defmethod to-vampir ((obj integer) value) +(defmethod to-vampir ((obj integer) value let-vars) "Numbers act like a constant function, ignoring input" (declare (ignore value)) - (vamp:make-constant :const obj)) + (values + (vamp:make-constant :const obj) + let-vars)) -(defmethod to-vampir ((obj ident) value) +(defmethod to-vampir ((obj ident) value let-vars) "Identity acts as the identity function" - value) + (values value let-vars)) -(defun infix-creation (symbol obj value) - (vamp:make-infix :op symbol - :lhs (to-vampir (mcar obj) value) - :rhs (to-vampir (mcadr obj) value))) +(defun infix-creation (symbol obj value let-vars) + (mvlet* ((lhs let-vars (to-vampir (mcar obj) value let-vars)) + (rhs let-vars (to-vampir (mcadr obj) value let-vars))) + (values (vamp:make-infix :op symbol :lhs lhs :rhs rhs) + let-vars))) + +(defun infix (op lhs rhs) + (vamp:make-infix :op op :lhs lhs :rhs rhs)) -(defmethod to-vampir ((obj +) value) +(defmethod to-vampir ((obj +) value let-vars) "Propagates the value and adds them" - (infix-creation :+ obj value)) + (infix-creation :+ obj value let-vars)) -(defmethod to-vampir ((obj *) value) +(defmethod to-vampir ((obj *) value let-vars) "Propagates the value and times them" - (infix-creation :* obj value)) + (infix-creation :* obj value let-vars)) -(defmethod to-vampir ((obj -) value) +(defmethod to-vampir ((obj -) value let-vars) "Propagates the value and subtracts them" - (infix-creation :- obj value)) + (infix-creation :- obj value let-vars)) -(defmethod to-vampir ((obj /) value) +(defmethod to-vampir ((obj /) value let-vars) ;; this should error - (infix-creation :/ obj value)) - -(defmethod to-vampir ((obj compose) value) - (to-vampir (mcar obj) - (to-vampir (mcadr obj) value))) + (infix-creation :/ obj value let-vars)) -(defun infix (op lhs rhs) - (vamp:make-infix :op op :lhs lhs :rhs rhs)) +(defmethod to-vampir ((obj compose) value let-vars) + (mvlet* ((fst let-vars (to-vampir (mcadr obj) value let-vars)) + (fst-wire (vamp:make-wire :var (gensym "C"))) + (fst-var (vamp:make-bind :names (list fst-wire) :value fst))) + (to-vampir (mcar obj) fst-wire (cons fst-var let-vars)))) -(defmethod to-vampir ((obj if-zero) value) +(defmethod to-vampir ((obj if-zero) value let-vars) "The PREDICATE that comes in must be 1 or 0 for the formula to work out." ;; need to optimize this, we are computing predicate twice which is ;; very bad (multiple-value-bind (predicate then else) obj - (let ((pred (to-vampir predicate value))) + (mvlet* ((predicate let-vars (to-vampir predicate value let-vars)) + (then let-vars (to-vampir then value let-vars)) + (else let-vars (to-vampir else value let-vars))) ;; bool × then + (1 - bool) × else - (infix :+ - (infix :* pred (to-vampir then value)) - (infix :* - (infix :- (vamp:make-constant :const 1) pred) - (to-vampir else value)))))) - -(defmethod to-vampir ((obj mod) value) - (geb.vampir:mod32 (to-vampir (mcar obj) value) - (to-vampir (mcadr obj) value))) - -(defmethod to-vampir ((obj if-lt) value) - (geb.vampir:pwless32 (to-vampir (mcar obj) value) - (to-vampir (mcadr obj) value) - (to-vampir (then obj) value) - (to-vampir (else obj) value))) + (let* ((pred (vamp:make-wire :var (gensym "ZP"))) + (pred-bind (vamp:make-bind :names (list pred) + :value predicate))) + (values + (infix :+ + (infix :* pred then) + (infix :* + (infix :- (vamp:make-constant :const 1) pred) + else)) + (cons pred-bind let-vars)))))) + +(defmethod to-vampir ((obj mod) value let-vars) + (mvlet* ((car let-vars (to-vampir (mcar obj) value let-vars)) + (cadr let-vars (to-vampir (mcadr obj) value let-vars))) + (values (geb.vampir:mod32 car cadr) + let-vars))) + +(defmethod to-vampir ((obj if-lt) value let-vars) + (mvlet* ((car let-vars (to-vampir (mcar obj) value let-vars)) + (cadr let-vars (to-vampir (mcadr obj) value let-vars)) + (then let-vars (to-vampir (then obj) value let-vars)) + (else let-vars (to-vampir (else obj) value let-vars))) + (values (geb.vampir:pwless32 car cadr then else) + let-vars))) + +(defmethod to-vampir ((obj geb.extension.spec:common-sub-expression) value let-vars) + (if (typep (obj obj) 'ident) + (to-vampir (obj obj) value let-vars) + ;; functions are only 1 argument big ☹ + (values (vamp:make-application :func (name obj) + :arguments (list value)) + let-vars))) diff --git a/src/specs/extension-printer.lisp b/src/specs/extension-printer.lisp new file mode 100644 index 000000000..876573c2d --- /dev/null +++ b/src/specs/extension-printer.lisp @@ -0,0 +1,67 @@ +;; We use CL streams as they are much better for concatenating to, and +;; have us worry less. they are a mutable interface however. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FORMAT RUNDOWN FOR THOSE WHO ARE UNFAMILIAR +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node257.html + +;; DSL FOR NEWLINES AND CONTROL OF IT + +;; ~4I = (pprint-indent :block 4) +;; ~4:I = (pprint-indent :current 4) +;; ~_ = (pprint-newline :linear) +;; ~@_ = (pprint-newline :miser) +;; ~:@_ = (pprint-newline :mandatory) +;; ~:_ = (pprint-newline :fill) + + +;; FOR PRINTING NORMALLY NOTE THESE TAKE ARGUMENTS! + +;; ~(~a~) = print symbol lower case instead of upper case +;; ~{~A~} = prints a list element by element. + +;; ~{~A~^ ~} = prints a list element by element, the last element of +;; the list does not print the extra space +;; EXAMPLE: +;; CL-USER> (format nil "~{~A~^ ~}" (list 1 2 3 4 5)) +;; "1 2 3 4 5" +;; CL-USER> (format nil "~{~A ~}" (list 1 2 3 4 5)) +;; "1 2 3 4 5 " + + +(in-package #:geb.extension.spec) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Subst Constructor Printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro with-alias-overide ((obj stream) &body otherwise) + "Prints out an alias instead of the body if it can detect an alias. + +Effectively this overrides any printing that would naturally occur" + (let ((alias (gensym)) + (in-there (gensym))) + `(multiple-value-bind (,alias ,in-there) (geb.mixins:meta-lookup ,obj :alias) + (if ,in-there + (format ,stream "~W" ,alias) + (progn ,@otherwise))))) + +(defmethod print-object ((obj reference) stream) + (with-alias-overide (obj stream) + (format stream "~W" (name obj)))) + +(defmethod print-object ((obj opaque) stream) + (with-alias-overide (obj stream) + (format stream "~W" (name obj)))) + +(defmethod print-object ((obj opaque-morph) stream) + (with-alias-overide (obj stream) + (print-unreadable-object (obj stream) + (format stream "DOM: ~W~_ CODOM: ~W" (dom obj) (codom obj))))) + +(defmethod print-object ((obj common-sub-expression) stream) + (print-unreadable-object (obj stream) + (print-object (obj obj) stream))) + diff --git a/src/specs/extension.lisp b/src/specs/extension.lisp new file mode 100644 index 000000000..364c4dbd7 --- /dev/null +++ b/src/specs/extension.lisp @@ -0,0 +1,56 @@ +(in-package :geb.extension.spec) + +;; Sadly no polynomial category to extend ☹ +(defclass common-sub-expression (direct-pointwise-mixin meta-mixin cat-morph) + ((obj :initarg :obj + :accessor obj) + (name :initarg :name + :accessor name)) + (:documentation + "I represent common sub-expressions found throughout the code. + +I implement a few categorical extensions. I am a valid +[CAT-MORPH][class] along with fulling the interface for the +[GEB.POLY.SPEC:] category. + +The name should come from an algorithm that automatically fines common +sub-expressions and places the appropriate names.")) + + +(defclass opaque (cat-obj meta-mixin) + ((name :initarg :name :accessor name) + (code :initarg :code :accessor code)) + (:documentation + "I represent an object where we want to hide the implementation +details of what kind of [GEB:SUBSTOBJ][type] I am.")) + +(defclass reference (cat-obj cat-morph direct-pointwise-mixin meta-mixin) + ((name :initarg :name :accessor name)) + (:documentation + "I represent a reference to an [OPAQUE][class] identifier.")) + +(defclass opaque-morph (cat-morph meta-mixin) + ((code :initarg :code + :accessor code + :documentation "the code that represents the underlying morphsism") + (dom :initarg :dom + :accessor dom + :documentation "The dom of the opaque morph") + (codom :initarg :codom + :accessor codom + :documentation "The codom of the opaque morph")) + (:documentation + "This represents a morphsim where we want to deal with an +[OPAQUE][class] that we know intimate details of")) + +(defun make-common-sub-expression (&key obj name) + (make-instance 'common-sub-expression :obj obj :name name)) + +(defun reference (name) + (make-instance 'reference :name name)) + +(defun opaque-morph (code &key (dom (dom code)) (codom (codom code))) + (make-instance 'opaque-morph :code code :dom dom :codom codom)) + +(defun opaque (name code) + (make-instance 'opaque :name name :code code)) diff --git a/src/specs/geb-printer.lisp b/src/specs/geb-printer.lisp index bd6b528b0..9e1663564 100644 --- a/src/specs/geb-printer.lisp +++ b/src/specs/geb-printer.lisp @@ -44,9 +44,10 @@ "Prints out an alias instead of the body if it can detect an alias. Effectively this overrides any printing that would naturally occur" - (let ((alias (gensym))) - `(let ((,alias (geb.mixins:meta-lookup ,obj :alias))) - (if ,alias + (let ((alias (gensym)) + (in-there (gensym))) + `(multiple-value-bind (,alias ,in-there) (geb.mixins:meta-lookup ,obj :alias) + (if ,in-there (format ,stream "~W" ,alias) (progn ,@otherwise))))) diff --git a/src/specs/geb.lisp b/src/specs/geb.lisp index ac67ae3d7..48bb4592f 100644 --- a/src/specs/geb.lisp +++ b/src/specs/geb.lisp @@ -104,16 +104,16 @@ us the right unit.")) :accessor mcadr :documentation "")) (:documentation - "The [PRODUCT][PROD type] object. Takes two CAT-OBJ values that + "The [PRODUCT][PROD class] object. Takes two CAT-OBJ values that get put into a pair. -The formal grammar of [PRODUCT][PROD type] is +The formal grammar of [PRODUCT][PROD class] is ```lisp (prod mcar mcadr) ``` -where [PROD][type] is the constructor, [MCAR] is the left value of the +where [PROD][class] is the constructor, [MCAR] is the left value of the product, and [MCADR] is the right value of the product. Example: @@ -135,7 +135,7 @@ Here we create a product of two [GEB-BOOL:BOOL] types.")) "the [CO-PRODUCT][COPROD class] object. Takes CAT-OBJ values that get put into a choice of either value. -The formal grammar of [PRODUCT][PROD type] is +The formal grammar of [PRODUCT][PROD class] is ```lisp (coprod mcar mcadr) @@ -176,7 +176,7 @@ values.")) "The composition morphism. Takes two CAT-MORPH values that get applied in standard composition order. -The formal grammar of [COMP][type] is +The formal grammar of [COMP][class] is ```lisp (comp mcar mcadr) @@ -188,7 +188,7 @@ which may be more familiar as g 。f ``` -Where [COMP][type]\\( 。\\) is the constructor, [MCAR]\\(g\\) is the second morphism +Where [COMP][class]\\( 。\\) is the constructor, [MCAR]\\(g\\) is the second morphism that gets applied, and [MCADR]\\(f\\) is the first morphism that gets applied. @@ -204,12 +204,12 @@ Example: In this example we are composing two morphisms. the first morphism that gets applied ([PAIR] ...) is the identity function on the -type ([PROD][type] [SO1][class] [GEB-BOOL:BOOL]), where we pair the +type ([PROD][class] [SO1][class] [GEB-BOOL:BOOL]), where we pair the [left projection](PROJECT-LEFT) and the [right projection](PROJECT-RIGHT), followed by taking the [right projection](PROJECT-RIGHT) of the type. -Since we know ([COMP][type] f id) is just f per the laws of category +Since we know ([COMP][class] f id) is just f per the laws of category theory, this expression just reduces to ```lisp @@ -222,16 +222,16 @@ theory, this expression just reduces to :type cat-obj :documentation "")) (:documentation - "The [INITIAL][INIT type] Morphism, takes any [CAT-OBJ] and + "The [INITIAL][INIT class] Morphism, takes any [CAT-OBJ] and creates a moprhism from [SO0][class] (also known as void) to the object given. -The formal grammar of [INITIAL][INIT type] is +The formal grammar of [INITIAL][INIT class] is ```lisp (init obj) ``` -where [INIT][type] is the constructor. [OBJ] is the type of object +where [INIT][class] is the constructor. [OBJ] is the type of object that will be conjured up from [SO0][class], when the morphism is applied onto an object. @@ -249,16 +249,16 @@ In this example we are creating a unit value out of void.")) :type cat-obj :documentation "")) (:documentation - "The [TERMINAL][type] morphism, Takes any [CAT-OBJ] and creates a + "The [TERMINAL][class] morphism, Takes any [CAT-OBJ] and creates a morphism from that object to [SO1][class] (also known as unit). -The formal grammar of [TERMINAL][type] is +The formal grammar of [TERMINAL][class] is ```lisp (terminal obj) ``` -where [TERMINAL][type] is the constructor. [OBJ] is the type of object that +where [TERMINAL][class] is the constructor. [OBJ] is the type of object that will be mapped to [SO1][class], when the morphism is applied onto an object. @@ -380,7 +380,7 @@ gets applied on the left coproduct while the other gets applied on the right coproduct. The result of each CAT-MORPH values must be the same. -The formal grammar of [CASE][type] is: +The formal grammar of [CASE][class] is: ```lisp (mcase mcar mcadr) @@ -451,20 +451,20 @@ projects back the GEB-BOOL:BOOL field as the second values.")) :type cat-obj :documentation "")) (:documentation - "The [LEFT PROJECTION][PROJECT-LEFT type]. Takes two + "The [LEFT PROJECTION][PROJECT-LEFT class]. Takes two [CAT-MORPH] values. When the [LEFT PROJECTION][PROJECT-LEFT -type] morphism is then applied, it grabs the left value of a product, +class] morphism is then applied, it grabs the left value of a product, with the type of the product being determined by the two [CAT-MORPH] values given. -the formal grammar of a [PROJECT-LEFT][type] is: +the formal grammar of a [PROJECT-LEFT][class] is: ```lisp (<-left mcar mcadr) ``` Where [<-LEFT] is the constructor, [MCAR] is the left type of the -[PRODUCT][type] and [MCADR] is the right type of the [PRODUCT][type]. +[PRODUCT][class] and [MCADR] is the right type of the [PRODUCT][class]. Example: @@ -476,7 +476,7 @@ Example: In this example, we are getting the left [GEB-BOOL:BOOL] from a product with the shape -([GEB-BOOL:BOOL][] [×][PROD type] [SO1][class] [×][PROD type] [GEB-BOOL:BOOL])")) +([GEB-BOOL:BOOL][] [×][PROD class] [SO1][class] [×][PROD class] [GEB-BOOL:BOOL])")) (defclass project-right () ((mcar :initarg :mcar @@ -487,21 +487,21 @@ product with the shape :accessor mcadr :type cat-obj :documentation "Right projection (product elimination)")) - (:documentation "The [RIGHT PROJECTION][PROJECT-RIGHT type]. Takes two + (:documentation "The [RIGHT PROJECTION][PROJECT-RIGHT class]. Takes two [CAT-MORPH] values. When the [RIGHT PROJECTION][PROJECT-RIGHT -type] morphism is then applied, it grabs the right value of a product, +class] morphism is then applied, it grabs the right value of a product, with the type of the product being determined by the two [CAT-MORPH] values given. -the formal grammar of a [PROJECT-RIGHT][type] is: +the formal grammar of a [PROJECT-RIGHT][class] is: ```lisp (<-right mcar mcadr) ``` Where [<-RIGHT] is the constructor, [MCAR] is the right type of the -[PRODUCT][type] and [MCADR] is the right type of the [PRODUCT][type]. +[PRODUCT][class] and [MCADR] is the right type of the [PRODUCT][class]. Example: @@ -514,7 +514,7 @@ Example: In this example, we are getting the right [GEB-BOOL:BOOL] from a product with the shape -([GEB-BOOL:BOOL][] [×][PROD type] [SO1][class] [×][PROD type] [GEB-BOOL:BOOL])")) +([GEB-BOOL:BOOL][] [×][PROD class] [SO1][class] [×][PROD class] [GEB-BOOL:BOOL])")) (defclass distribute () ((mcar :initarg :mcar @@ -599,7 +599,9 @@ product with the shape obj) (defun has-aliasp (obj) - (geb.mixins:meta-lookup obj :alias)) + (multiple-value-bind (val in-there) (geb.mixins:meta-lookup obj :alias) + (declare (ignore val)) + in-there)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Constructors for the morphism constructors diff --git a/src/specs/lambda-printer.lisp b/src/specs/lambda-printer.lisp new file mode 100644 index 000000000..fdc1b71bb --- /dev/null +++ b/src/specs/lambda-printer.lisp @@ -0,0 +1,20 @@ +(in-package #:geb.lambda.spec) + +(defmacro easy-printer (class-name) + `(defmethod print-object ((obj ,class-name) stream) + (print-object (cons ',class-name + (mapcar #'cdr (geb.mixins:to-pointwise-list obj))) + stream))) + +(easy-printer absurd) +(easy-printer unit) +(easy-printer left) +(easy-printer right) +(easy-printer case-on) +(easy-printer pair) +(easy-printer fst) +(easy-printer snd) +(easy-printer lamb) +(easy-printer app) +(easy-printer index) +(easy-printer err) diff --git a/src/specs/lambda.lisp b/src/specs/lambda.lisp index 5e91d3fd0..1259fb390 100644 --- a/src/specs/lambda.lisp +++ b/src/specs/lambda.lisp @@ -1,38 +1,558 @@ (in-package #:geb.lambda.spec) -;; maybe expand this macro and change each defconstant into a proper -;; class declaration. We avoid typing it as we don't actually want to -;; be exhaustive, but rather open. -(defunion stlc - (absurd (cod geb.spec:substmorph) (value t)) - unit - (left (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (right (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (case-on (lty geb.spec:substmorph) - (rty geb.spec:substmorph) - (cod geb.spec:substmorph) - (on t) (left t) (right t)) - (pair (lty geb.spec:substmorph) (rty geb.spec:substmorph) (left t) (right t)) - (fst (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (snd (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (lamb (vty geb.spec:substmorph) (tty geb.spec:substmorph) (value t)) - (app (dom geb.spec:substmorph) (cod geb.spec:substmorph) (func t) (obj t)) - (index (index fixnum))) - -;; because we are doing this with a struct and not a class, however -;; since serapeum defines out `make-load-form' to the -;; read-only-structs we can derive it like such - -(defmethod geb.mixins:obj-equalp ((obj1 ) (obj2 )) - (when (equalp (type-of obj1) (type-of obj2)) - (every (lambda (x y) (geb.mixins:obj-equalp x y)) - (make-load-form obj1) - (make-load-form obj2)))) - -(defstruct-read-only typed-stlc - (value unit :type ) - (type t :type t)) - -(defun typed (v typ) - "Puts together the type declaration with the value itself for lambda terms" - (make-typed-stlc :value v :type typ)) +(defclass (geb.mixins:direct-pointwise-mixin geb.mixins:meta-mixin geb.mixins:cat-obj) () + (:documentation + "Class of untyped terms of simply typed lambda claculus. Given our +presentation, we look at the latter as a type theory spanned by empty, +unit types as well as coproduct, product, and function types.")) + +(deftype stlc () + "Type of untyped terms of [STLC][type]. Each class of a term has a slot for a type, +which can be filled by auxillary functions or by user. Types are +represented as [SUBSTOBJ][GEB.SPEC:SUBSTOBJ]." + '(or absurd unit left right case-on pair fst snd lamb app index err)) + +;; New defgenerics + +(defgeneric term (obj)) +(defgeneric tdom (obj)) +(defgeneric tcod (obj)) +(defgeneric ttype (obj)) +(defgeneric rty (obj)) +(defgeneric lty (obj)) +(defgeneric ltm (obj)) +(defgeneric rtm (obj)) +(defgeneric on (obj)) +(defgeneric fun (obj)) +(defgeneric pos (obj)) + + +(defclass absurd () + ((tcod :initarg :tcod + :accessor tcod + :documentation "An arbitrary type") + (term :initarg :term + :accessor term + :documentation "A term of the empty type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "The [ABSURD][class] term provides an element of an arbitrary type +given a term of the empty type, denoted by [SO0][GEB.SPEC:SO0 class]. +The formal grammar of [ABSURD][class] is + +```lisp +(absurd tcod term) +``` + +where we possibly can include type information by + +```lisp +(absurd tcod term :ttype ttype) +``` + +The intended semantics are: [TCOD] is a type whose term we want to +get (and hence a [SUBSTOBJ] [GEB.SPEC:SUBSTOBJ]) and [TERM] is a term +of the empty type (and hence an [STLC][type]. + +This corresponds to the elimination rule of the empty type. Namely, +given +$$\\Gamma \\vdash \\text{tcod : Type}$$ and +$$\\Gamma \\vdash \\text{term : so0}$$ one deduces +$$\\Gamma \\vdash \\text{(absurd tcod term) : tcod}$$")) + +(-> absurd (cat-obj &key (:ttype t)) absurd) +(defun absurd (tcod term &key (ttype nil)) + (values + (make-instance 'absurd :tcod tcod :term term :ttype ttype))) + +(defclass unit () + ((ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "The unique term of the unit type, the latter represented by +[SO1][GEB.SPEC:SO1 class]. The formal grammar of [UNIT][class] is + +```lisp +(unit) +``` + +where we can optionally include type information by + +```lisp +(unit :ttype ttype) +``` + +Clearly the type of [UNIT][class] is [SO1][GEB.SPEC:SO1 class] but here +we provide all terms untyped. + +This grammar corresponds to the introduction rule of the unit type. Namely +$$\\Gamma \\dashv \\text{(unit) : so1}$$")) + +(-> unit (&key (:ttype t)) unit) +(defun unit (&key (ttype nil)) + (values + (make-instance 'unit :ttype ttype))) + +(defclass left () + ((rty :initarg :rty + :accessor rty + :documentation "Right argument of coproduct type") + (term :initarg :term + :accessor term + :documentation "Term of the left argument of coproduct type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "Term of a coproduct type gotten by injecting into the left type of the coproduct. The formal grammar of +[LEFT][class] is + +```lisp +(left rty term) +``` + +where we can include optional type information by + +```lisp +(left rty term :ttype ttype) +``` + +The indended semantics are as follows: [RTY][generic-function] should +be a type (and hence a [SUBSTOBJ][GEB.SPEC:SUBSTOBJ]) and specify the +right part of the coproduct of the type [TTYPE][generic-function] of +the entire term. The term (and hence an [STLC][type]) we are injecting +is [TERM][generic-function]. + +This corresponds to the introduction rule of the coproduct type. Namely, given +$$\\Gamma \\dashv \\text{(ttype term) : Type}$$ and +$$\\Gamma \\dashv \\text{rty : Type}$$ +with +$$\\Gamma \\dashv \\text{term : (ttype term)}$$ we deduce +$$\\Gamma \\dashv \\text{(left rty term) : (coprod (ttype term) rty)}$$ +")) + +(-> left (cat-obj &key (:ttype t)) left) +(defun left (rty term &key (ttype nil)) + (values + (make-instance 'left :rty rty :term term :ttype ttype))) + +(defclass right () + ((lty :initarg :lty + :accessor lty + :documentation "Left argument of coproduct type") + (term :initarg :term + :accessor term + :documentation "Term of the right argument of coproduct type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "Term of a coproduct type gotten by injecting into the right type of +the coproduct. The formal grammar of [RIGHT][class] is + +```lisp +(right lty term) +``` + +where we can include optional type information by + +```lisp +(right lty term :ttype ttype) +``` + +The indended semantics are as follows: [LTY] should be a type (and +hence a [SUBSTOBJ][GEB.SPEC:SUBSTOBJ]) and specify the left part of +the coproduct of the type [TTYPE] of the entire term. The term (and +hence an [STLC][type]) we are injecting is [TERM]. + +This corresponds to the introduction rule of the coproduct type. Namely, given +$$\\Gamma \\dashv \\text{(ttype term) : Type}$$ and +$$\\Gamma \\dashv \\text{lty : Type}$$ +with +$$\\Gamma \\dashv \\text{term : (ttype term)}$$ we deduce +$$\\Gamma \\dashv \\text{(right lty term) : (coprod lty (ttype term))}$$ +")) + +(-> right (cat-obj &key (:ttype t)) right) +(defun right (lty term &key (ttype nil)) + (values + (make-instance 'right :lty lty :term term :ttype ttype))) + +(defclass case-on () + ((on :initarg :on + :accessor on + :documentation "Term of coproduct type") + (ltm :initarg :ltm + :accessor ltm + :documentation "Term in context of left argument of coproduct type") + (rtm :initarg :rtm + :accessor rtm + :documentation "Term in context of right argument of coproduct type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "A term of an arbutrary type provided by casing on a coproduct term. The +formal grammar of [CASE-ON][class] is + +```lisp +(case-on on ltm rtm) +``` + +where we can possibly include type information by + +```lisp +(case-on on ltm rtm :ttype ttype) +``` + +The intended semantics are as follows: [ON] is a term (and hence an +[STLC][type]) of a coproduct type, and [LTM] and [RTM] terms (hence +also [STLC][type]) of the same type in the context of - appropriately +- (mcar (ttype on)) and (mcadr (ttype on)). + +This corresponds to the elimination rule of the coprodut type. Namely, given +$$\\Gamma \\vdash \\text{on : (coprod (mcar (ttype on)) (mcadr (ttype on)))}$$ +and +$$\\text{(mcar (ttype on))} , \\Gamma \\vdash \\text{ltm : (ttype ltm)}$$ +, $$\\text{(mcadr (ttype on))} , \\Gamma \\vdash \\text{rtm : (ttype ltm)}$$ +we get +$$\\Gamma \\vdash \\text{(case-on on ltm rtm) : (ttype ltm)}$$ +Note that in practice we append contexts on the left as computation of +[INDEX][class] is done from the left. Otherwise, the rules are the same as in +usual type theory if context was read from right to left.")) + +(-> case-on ( &key (:ttype t)) case-on) +(defun case-on (on ltm rtm &key (ttype nil)) + (values + (make-instance 'case-on :on on :ltm ltm :rtm rtm :ttype ttype))) + +(defclass pair () + ((ltm :initarg :ltm + :accessor ltm + :documentation "Term of left argument of the product type") + (rtm :initarg :rtm + :accessor rtm + :documentation "Term of right argument of the product type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "A term of the product type gotten by pairing a terms of a left and right +parts of the product. The formal grammar of [PAIR][class] is + +```lisp +(pair ltm rtm) +``` + +where we can possibly include type information by + +```lisp +(pair ltm rtm :ttype ttype) +``` + +The intended semantics are as follows: [LTM] is a term (and hence an +[STLC][type]) of a left part of the product type whose terms we are +producing. [RTM] is a term (hence also [STLC][type])of the right part +of the product. + +The grammar corresponds to the introdcution rule of the pair type. Given +$$\\Gamma \\vdash \\text{ltm : (mcar (ttype (pair ltm rtm)))}$$ and +$$\\Gamma \\vdash \\text{rtm : (mcadr (ttype (pair ltm rtm)))}$$ we have +$$\\Gamma \\vdash \\text{(pair ltm rtm) : (ttype (pair ltm rtm))}$$ +")) + +(-> pair ( &key (:ttype t)) pair) +(defun pair (ltm rtm &key (ttype nil)) + (values + (make-instance 'pair :ltm ltm :rtm rtm :ttype ttype))) + +(defclass fst () + ((term :initarg :term + :accessor term + :documentation "Term of product type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "The first projection of a term of a product type. +The formal grammar of [FST][class] is: + +```lisp +(fst term) +``` + +where we can possibly include type information by + +```lisp +(fst term :ttype ttype) +``` + +The indended semantics are as follows: [TERM][generic-function] is a +term (and hence an [STLC][type]) of a product type, to whose left part +we are projecting to. + +This corresponds to the first projection function gotten by induction +on a term of a product type.")) + +(-> fst ( &key (:ttype t)) fst) +(defun fst (term &key (ttype nil)) + (values + (make-instance 'fst :term term :ttype ttype))) + +(defclass snd () + ((term :initarg :term + :accessor term + :documentation "Term of product type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "The second projection of a term of a product type. +The formal grammar of [SND][class] is: + +```lisp +(snd term) +``` + +where we can possibly include type information by + +```lisp +(snd term :ttype ttype) +``` + +The indended semantics are as follows: [TERM][generic-function] is a +term (and hence an [STLC][type]) of a product type, to whose right +part we are projecting to. + +This corresponds to the second projection function gotten by induction +on a term of a product type.")) + +(-> snd ( &key (:ttype t)) snd) +(defun snd (term &key (ttype nil)) + (values + (make-instance 'snd :term term :ttype ttype))) + +(defclass lamb () + ((tdom :initarg :tdom + :accessor tdom + :type list + :documentation "Domain of the lambda term") + (term :initarg :term + :accessor term + :documentation "Term of the codomain mapped to given a variable of tdom") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "A term of a function type gotten by providing a term in the codomain +of the function type by assuming one is given variables in the +specified list of types. [LAMB][class] takes in the [TDOM][generic-function] +accessor a list of types - and hence of [SUBSTOBJ][class] - and in the +[TERM][generic-function] a term - and hence an [STLC][type]. The formal grammar +of [LAMB][class] is: + +```lisp +(lamb tdom term) +``` + +where we can possibly include type information by + +```lisp +(lamb tdom term :ttype ttype) +``` + +The intended semnatics are: [TDOM][generic-function] is a list of types (and +hence a list of [SUBSTOBJ][GEB.SPEC:SUBSTOBJ]) whose iterative product of +components form the domain of the function type. [TERM][generic-function] +is a term (and hence an [STLC][type]) of the codomain of the function type +gotten in the context to whom we append the list of the domains. + +For a list of length 1, corresponds to the introduction rule of the function +type. Namely, given +$$\\Gamma \\vdash \\text{tdom : Type}$$ and +$$\\Gamma, \\text{tdom} \\vdash \\text{term : (ttype term)}$$ we have +$$\\Gamma \\vdash \\text{(lamb tdom term) : (so-hom-obj tdom (ttype term))}$$ + +For a list of length n, this coreesponds to the iterated lambda type, e.g. + +```lisp +(lamb (list so1 so0) (index 0)) +``` + +is a term of + +```lisp +(so-hom-obj (prod so1 so0) so0) +``` + +or equivalently + +```lisp +(so-hom-obj so1 (so-hom-obj so0 so0)) +``` + +due to Geb's computational definition of the function type. + +Note that [INDEX][class] 0 in the above code is of type [SO1][class]. +So that after annotating the term, one gets + +```lisp +LAMBDA> (ttype (term (lamb (list so1 so0)) (index 0))) +s-1 +``` + +So the counting of indeces starts with the leftmost argument for +computational reasons. In practice, typing of [LAMB][class] corresponds with +taking a list of arguments provided to a lambda term, making it a context +in that order and then counting the index of the varibale. Type-theoretically, + +$$\\Gamma \\vdash \\lambda \\Delta (index i)$$ +$$\\Delta, \\Gamma \\vdash (index i)$$ + +So that by the operational semantics of [INDEX][class], the type of (index i) +in the above context will be the i'th element of the Delta context counted from +the left. Note that in practice we append contexts on the left as computation of +[INDEX][class] is done from the left. Otherwise, the rules are the same as in +usual type theory if context was read from right to left.")) + +(-> lamb (list &key (:ttype t)) lamb) +(defun lamb (tdom term &key (ttype nil)) + (values + (make-instance 'lamb :tdom tdom :term term :ttype ttype))) + +(defclass app () + ((fun :initarg :fun + :accessor fun + :documentation "Term of exponential type") + (term :initarg :term + :accessor term + :type list + :documentation "List of Terms of the domain") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "A term of an arbitrary type gotten by applying a function of an iterated +function type with a corresponding codomain iteratively to terms in the +domains. [APP][class] takes as argument for the [FUN][generic-function] accessor +a function - and hence an [STLC][type] - whose function type has domain an +iterated [GEB:PROD][class] of [SUBSTOBJ][clas] and for the [TERM][generic-function] +a list of terms - and hence of [STLC][type] - matching the types of the +product. The formal grammar of [APP][class] is + +```lisp +(app fun term) +``` + +where we can possibly include type information by + +```lisp +(app fun term :ttype ttype) +``` + +The intended semantics are as follows: +[FUN][generic-function] is a term (and hence an [STLC][type]) of a coproduct + type - say of (so-hom-obj (ttype term) y) - and [TERM][generic-function] is a +list of terms (hence also of [STLC][type]) with nth term in the list having the +n-th part of the function type. + +For a one-argument term list, this corresponds to the elimination rule of the +function type. Given +$$\\Gamma \\vdash \\text{fun : (so-hom-obj (ttype term) y)}$$ and +$$\\Gamma \\vdash \\text{term : (ttype term)}$$ we get +$$\\Gamma \\vdash \\text{(app fun term) : y}$$ + +For several arguments, this corresponds to successive function application. +Using currying, this corresponds to, given + +``` +G ⊢ (so-hom-obj (A₁ × ··· × Aₙ₋₁) Aₙ) +G ⊢ f : (so-hom-obj (A₁ × ··· × Aₙ₋₁) +G ⊢ tᵢ : Aᵢ +``` + +then for each `i` less than `n` gets us + +```lisp +G ⊢ (app f t₁ ··· tₙ₋₁) : Aₙ +``` + +Note again that i'th term should correspond to the ith element of the product +in the codomain counted from the left.")) + +(-> app ( list &key (:ttype t)) app) +(defun app (fun term &key (ttype nil)) + (values + (make-instance 'app :fun fun :term term :ttype ttype))) + +(defclass index () + ((pos :initarg :pos + :accessor pos + :documentation "Position of type") + (ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "The variable term of an arbitrary type in a context. The formal +grammar of [INDEX][class] is + +```lisp +(index pos) +``` + +where we can possibly include type information by + +```lisp +(index pos :ttype ttype) +``` + +The intended semantics are as follows: [POS][generic-function] is a +natural number indicating the position of a type in a context. + +This corresponds to the variable rule. Namely given a context +$$\\Gamma_1 , \\ldots , \\Gamma_{pos} , \\ldots , \\Gamma_k $$ we have + +$$\\Gamma_1 , \\ldots , \\Gamma_k \\vdash \\text{(index pos) :} \\Gamma_{pos}$$ + +Note that we add contexts on the left rather than on the right contra classical +type-theoretic notation.")) + +(-> index (fixnum &key (:ttype t)) index) +(defun index (pos &key (ttype nil)) + (values + (make-instance 'index :pos pos :ttype ttype))) + +(defclass err () + ((ttype :initarg :ttype + :initform nil + :accessor ttype + :documentation "")) + (:documentation + "An error term of a type supplied by the user. The formal grammar of +[ERR][class] is +```lisp +(err ttype) +``` +The intended semantics are as follows: [ERR][class] represents an error node +currently having no particular feedback but with functionality to be of an +arbitrary type. Note that this is the only STLC term class which does not +have [TTYPE][generic-function] a possibly empty accessor.")) + +(-> err (cat-obj) err) +(defun err (ttype) + (values + (make-instance 'err :ttype ttype))) diff --git a/src/specs/package.lisp b/src/specs/package.lisp index 2d868dcac..b1e060dd5 100644 --- a/src/specs/package.lisp +++ b/src/specs/package.lisp @@ -19,7 +19,7 @@ (muffle-package-variance (uiop:define-package #:geb.lambda.spec (:documentation "Basic spec for creating lambda terms") - (:mix #:trivia #:serapeum #:common-lisp))) + (:mix #:trivia #:serapeum #:common-lisp #:geb.mixins))) (pax:define-package #:geb.spec (:documentation "Gödel, Escher, Bach categorical model") @@ -28,6 +28,11 @@ (:export :prod :case :mcar :mcadr :mcaddr :mcdr :name :func :obj :same-type-to-list :pair-to-list)) +(muffle-package-variance + (uiop:define-package #:geb.extension.spec + (:documentation "Extensions of the various categories") + (:mix #:trivia #:serapeum #:common-lisp #:geb.mixins #:geb.utils))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Geb Package Documentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -137,81 +142,103 @@ constructors" (pax:defsection @lambda-specs (:title "Lambda Specification") "This covers the various the abstract data type that is the simply - typed lambda calculus within GEB. - -The specification follows from the sum type declaration - -```lisp -(defunion stlc - (absurd (value t)) - unit - (left (value t)) - (right (value t)) - (case-on (lty geb.spec:substmorph) - (rty geb.spec:substmorph) - (cod geb.spec:substmorph) - (on t) (left t) (right t)) - (pair (lty geb.spec:substmorph) (rty geb.spec:substmorph) (left t) (right t)) - (fst (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (snd (lty geb.spec:substmorph) (rty geb.spec:substmorph) (value t)) - (lamb (vty geb.spec:substmorph) (tty geb.spec:substmorph) (value t)) - (app (dom geb.spec:substmorph) (cod geb.spec:substmorph) (func t) (obj t)) - (index (index fixnum))) -``` + typed lambda calculus within GEB. The class presents untyped STLC terms. " - ( pax:type) (stlc pax:type) - (absurd pax:type) - (absurd-value pax:function) - - (unit pax:type) - - (pair pax:type) - (pair-lty pax:function) - (pair-rty pax:function) - (pair-left pax:function) - (pair-right pax:function) - - (left pax:type) - (left-value pax:function) - - (right pax:type) - (right-value pax:function) - - (case-on pax:type) - (case-on-lty pax:function) - (case-on-rty pax:function) - (case-on-cod pax:function) - (case-on-on pax:function) - (case-on-left pax:function) - (case-on-right pax:function) - - (fst pax:type) - (fst-lty pax:function) - (fst-rty pax:function) - (fst-value pax:function) - - (snd pax:type) - (snd-lty pax:function) - (snd-rty pax:function) - (snd-value pax:function) - - (lamb pax:type) - (lamb-vty pax:function) - (lamb-tty pax:function) - (lamb-value pax:function) - - (app pax:type) - (app-dom pax:function) - (app-cod pax:function) - (app-func pax:function) - (app-obj pax:function) - - (index pax:type) - (index-index pax:function) - - (typed pax:function) - (typed-stlc-type pax:function) (typed-stlc-value pax:function)) + ( pax:class) + + (absurd pax:class) + (unit pax:class) + (left pax:class) + (right pax:class) + (case-on pax:class) + (pair pax:class) + (fst pax:class) + (snd pax:class) + (lamb pax:class) + (app pax:class) + (index pax:class) + (err pax:class) + + (absurd pax:function) + (unit pax:function) + (left pax:function) + (right pax:function) + (case-on pax:function) + (pair pax:function) + (fst pax:function) + (snd pax:function) + (lamb pax:function) + (app pax:function) + (index pax:function) + (err pax:function) + + "Accessors of [ABSURD][class]" + + (tcod (pax:method () (absurd))) + (term (pax:method () (absurd))) + (ttype (pax:method () (absurd))) + + "Accessors of [UNIT][class]" + (ttype (pax:method () (unit))) + + "Accessors of [LEFT][class]" + (rty (pax:method () (left))) + (term (pax:method () (left))) + (ttype (pax:method () (left))) + + "Accessors of [RIGHT][class]" + (lty (pax:method () (right))) + (term (pax:method () (right))) + (ttype (pax:method () (right))) + + "Accessors of [CASE-ON][class]" + (on (pax:method () (case-on))) + (ltm (pax:method () (case-on))) + (rtm (pax:method () (case-on))) + (ttype (pax:method () (case-on))) + + "Accessors of [PAIR][class]" + (ltm (pax:method () (pair))) + (rtm (pax:method () (pair))) + (ttype (pax:method () (pair))) + + "Accessors of [FST][class]" + (term (pax:method () (fst))) + (ttype (pax:method () (fst))) + + "Accessors of [SND][class]" + (term (pax:method () (snd))) + (ttype (pax:method () (snd))) + + "Accessors of [LAMB][class]" + (tdom (pax:method () (lamb))) + (term (pax:method () (lamb))) + (ttype (pax:method () (lamb))) + + "Accessors of [APP][class]" + (fun (pax:method () (app))) + (term (pax:method () (app))) + (ttype (pax:method () (app))) + + "Accessors of [INDEX][class]" + (pos (pax:method () (index))) + (ttype (pax:method () (index))) + + "Accessors of [ERR][class]" + (ttype (pax:method () (err))) + + (tcod pax:generic-function) + (tdom pax:generic-function) + (term pax:generic-function) + (rty pax:generic-function) + (lty pax:generic-function) + (ltm pax:generic-function) + (rtm pax:generic-function) + (on pax:generic-function) + (fun pax:generic-function) + (pos pax:generic-function) + (ttype pax:generic-function)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Geb Package Documentation @@ -253,7 +280,7 @@ type substobj = so0 | prod | coprod ```" - (prod pax:type) + (prod pax:class) (coprod pax:class) (so0 pax:class) (so1 pax:class) @@ -293,10 +320,10 @@ type realized-object = so0 (pax:defsection @geb-substmorph (:title "Subst Morph") "The overarching types that categorizes the [SUBSTMORPH][type] category. Note that [SUBSTMORPH][type] refers to the -[GEB-DOCS/DOCS:@CLOSED-TYPE], whereas [\\][type] refers +[GEB-DOCS/DOCS:@CLOSED-TYPE], whereas [\\][class] refers to the [GEB-DOCS/DOCS:@OPEN-TYPE] that allows for user extension." (substmorph pax:type) - ( pax:type) + ( pax:class) "[SUBSTMORPH][type] type is not a constructor itself, instead it's best viewed as the sum type, with the types below forming the constructors for the term. In ML we would write it similarly to: @@ -319,17 +346,17 @@ Note that an instance of [SUBSTOBJ][type], acts like the identity morphism to the layout specified by the given [SUBSTOBJ][type]. Thus we can view this as automatically lifting a [SUBSTOBJ][type] into a [SUBSTMORPH][type]" - (comp pax:type) - (case pax:type) - (init pax:type) - (terminal pax:type) - (pair pax:type) - (distribute pax:type) - (inject-left pax:type) - (inject-right pax:type) - (project-left pax:type) - (project-right pax:type) - (functor pax:type) + (comp pax:class) + (case pax:class) + (init pax:class) + (terminal pax:class) + (pair pax:class) + (distribute pax:class) + (inject-left pax:class) + (inject-right pax:class) + (project-left pax:class) + (project-right pax:class) + (functor pax:class) "The @GEB-ACCESSORS specific to @GEB-SUBSTMORPH" (mcar (pax:method () (comp))) (mcadr (pax:method () (comp))) @@ -378,14 +405,30 @@ we can view this as automatically lifting a [SUBSTOBJ][type] into a (mcase pax:function) (make-functor pax:function)) -(pax:defsection @geb-accessors (:title "Accessors") - "These functions relate to grabbing slots out of the various - @GEB-SUBSTMORPH and @GEB-SUBSTMU types. See those sections for - specific instance documentation" - (mcar pax:generic-function) - (mcadr pax:generic-function) - (mcdr pax:generic-function) - (mcaddr pax:generic-function) - (obj pax:generic-function) - (name pax:generic-function) - (func pax:generic-function)) +(in-package :geb.extension.spec) + +(pax:defsection @geb-extensions (:title "Extension Sets for Categories") + "This package contains many extensions one may see over the codebase. + +Each extension adds an unique feature to the categories they are +extending. To learn more, read about the individual extension you are +interested in." + "Common Sub expressions represent repeat logic that can be found +throughout any piece of code" + (common-sub-expression pax:class) + (make-common-sub-expression pax:function) + "The Opaque extension lets users write categorical objects and + morphisms where their implementation hide the specifics of what + types they are operating over" + (opaque pax:class) + (reference pax:class) + (opaque-morph pax:class) + (code (pax:method () (opaque-morph))) + (dom (pax:method () (opaque-morph))) + (codom (pax:method () (opaque-morph))) + (code (pax:method () (opaque))) + (name (pax:method () (opaque))) + (name (pax:method () (reference))) + (reference pax:function) + (opaque-morph pax:function) + (opaque pax:function)) diff --git a/src/specs/poly.lisp b/src/specs/poly.lisp index 9c70e43ff..2cb96d5e0 100644 --- a/src/specs/poly.lisp +++ b/src/specs/poly.lisp @@ -128,7 +128,8 @@ (make-instance 'mod :mcar mcar :mcadr mcadr)) (defun if-zero (pred then else) - "checks if [PREDICATE] is zero then take the [THEN] branch otherwise the [ELSE] branch" + "checks if [PREDICATE] is zero then take the [THEN] branch otherwise +the [ELSE] branch" (make-instance 'if-zero :predicate pred :then then :else else)) (defun if-lt (mcar mcadr then else) diff --git a/src/util/package.lisp b/src/util/package.lisp index 058fd44fb..662625ed9 100644 --- a/src/util/package.lisp +++ b/src/util/package.lisp @@ -12,10 +12,12 @@ used throughout the GEB codebase" (muffle-package-variance pax:macro) (subclass-responsibility pax:function) (shallow-copy-object pax:function) + (copy-instance pax:generic-function) (make-pattern pax:macro) (number-to-digits pax:function) (digit-to-under pax:function) (number-to-under pax:function) + (apply-n pax:function) (@geb-accessors pax:section)) (pax:defsection @geb-accessors (:title "Accessors") @@ -32,4 +34,5 @@ used throughout the GEB codebase" (func pax:generic-function) (predicate pax:generic-function) (then pax:generic-function) - (else pax:generic-function)) + (else pax:generic-function) + (code pax:generic-function)) diff --git a/src/util/utils.lisp b/src/util/utils.lisp index c75a76634..d3798122d 100644 --- a/src/util/utils.lisp +++ b/src/util/utils.lisp @@ -69,6 +69,37 @@ if wanted copy)) +;; from +;; https://stackoverflow.com/questions/11067899/is-there-a-generic-method-for-cloning-clos-objects + +;; Don't need it to be an object on non standard-classes for this +;; project, if so, we can promote it to the old form of being a +;; defgeneric. + +(defgeneric copy-instance (object &rest initargs &key &allow-other-keys) + (:documentation + "Makes and returns a shallow copy of OBJECT. + + An uninitialized object of the same class as OBJECT is allocated by + calling ALLOCATE-INSTANCE. For all slots returned by + CLASS-SLOTS, the returned object has the + same slot values and slot-unbound status as OBJECT. + + REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")) + +(defmethod copy-instance ((object standard-object) &rest initargs &key &allow-other-keys) + (let* ((class (class-of object)) + (copy (allocate-instance class))) + (dolist (slot (c2mop:class-slots class)) + ;; moved the mapcar into a let, as allocation wise, CCL + ;; preformed better this way. + (let ((slot-name (c2mop:slot-definition-name slot))) + (when (slot-boundp object slot-name) + (setf (slot-value copy slot-name) + (slot-value object slot-name))))) + (values + (apply #'reinitialize-instance copy initargs)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Numeric Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -201,3 +232,24 @@ Further this can be used in type signatures (:documentation "the then branch of the [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)")) + +(defgeneric code (obj) + (:documentation + "the code of the +[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Additional Utils +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun apply-n (times f initial) + "Applies a function, f, n TIMES to the INITIAL values + +```lisp +GEB> (apply-n 10 #'1+ 0) +10 (4 bits, #xA, #o12, #b1010) +```" + (let ((value initial)) + (dotimes (n times value) + (setf value (funcall f value))))) diff --git a/src/vampir/package.lisp b/src/vampir/package.lisp index 8cb8bd867..ac7481ad1 100644 --- a/src/vampir/package.lisp +++ b/src/vampir/package.lisp @@ -37,39 +37,41 @@ (:shadowing-import-from #:geb.vampir.spec #:op #:tuple) (:shadowing-import-from #:common-lisp #:=) (:local-nicknames (#:spc #:geb.vampir.spec)) - (:export :extract + (:export + :extract - ;; vampir api functions - *bool* bool - *next-range* - next-range - *range32* - range32 + ;; vampir api functions + :*bool* + :bool + :*next-range* + :next-range + :*range32* + :range32 - *int-range32* - int-range32 + :*int-range32* + :int-range32 - *negative32* - negative32 + :*negative32* + :negative32 - *non-negative32* - non-negative32 + :*non-negative32* + :non-negative32 - *range31* - range31 + :*range31* + :range31 - *int-range31* - int-range31 + :*int-range31* + :int-range31 - *less32* - less32 + :*less32* + :less32 - *pwless32* - pwless32 + :*pwless32* + :pwless32 - *mod32* - mod32 + :*mod32* + :mod32 - *pwmod32* - pwmod32))) + :*pwmod32* + :pwmod32))) diff --git a/src/vampir/print.lisp b/src/vampir/print.lisp index adcba5716..23ba72745 100644 --- a/src/vampir/print.lisp +++ b/src/vampir/print.lisp @@ -94,7 +94,9 @@ of ()'s for any non normal form" (pprint-logical-block (stream nil :prefix "(" :suffix ")") (print-object expr stream))) ((or spc:tuple spc:normal-form) - (print-object expr stream))) + (print-object expr stream)) + (geb.extension.spec:common-sub-expression + (extract-expression (geb.spec:obj expr) stream))) stream) (defmethod print-object ((infix spc:infix) stream) diff --git a/src/vampir/spec.lisp b/src/vampir/spec.lisp index f455add03..f6e375764 100644 --- a/src/vampir/spec.lisp +++ b/src/vampir/spec.lisp @@ -9,16 +9,20 @@ ;; Sum Type Declarations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; please remove these geb types later + (deftype statement () `(or alias pub constraint)) (deftype constraint () - `(or application bind equality expression)) + `(or application bind equality expression + geb.extension.spec:common-sub-expression)) ;; called base in the file ;; Values are called over a normal form!?!?!? (deftype expression () - `(or infix application normal-form tuple)) + `(or infix application normal-form tuple + geb.extension.spec:common-sub-expression)) (deftype normal-form () `(or wire constant)) @@ -49,7 +53,7 @@ (defclass alias (mixins) ((name :initarg :name - :type keyword + :type (or symbol keyword) :accessor name :documentation "Name of the alias gate") (inputs :initarg :inputs @@ -92,9 +96,9 @@ :documentation "the argument to the right of the op"))) (defclass application (mixins) - ((func :initarg :function + ((func :initarg :func :accessor func - :type keyword + :type (or symbol keyword) :documentation "the alias we are calling") (arguments :initarg :arguments ;; I assume list of expressions? @@ -133,7 +137,7 @@ (defclass wire (mixins) ((var :initarg :var :accessor var - :type keyword)) + :type (or symbol keyword))) (:documentation "A reference in vamp-ir")) (defclass constant (mixins) @@ -145,7 +149,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (serapeum:-> make-alias - (&key (:name keyword) (:inputs list) (:body constraint-list)) + (&key (:name (or symbol keyword)) (:inputs list) (:body constraint-list)) alias) (defun make-alias (&key name inputs body) (values @@ -170,7 +174,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-application (&key func arguments) - (make-instance 'application :function func :arguments arguments)) + (make-instance 'application :func func :arguments arguments)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Bind diff --git a/src/vampir/vampir.lisp b/src/vampir/vampir.lisp index 422bba108..06971115b 100644 --- a/src/vampir/vampir.lisp +++ b/src/vampir/vampir.lisp @@ -347,5 +347,6 @@ (defun extract (stmts &optional (stream *standard-output*)) (let ((*print-pretty* t) (*print-miser-width* 40)) - (format stream "~{~A~^~%~}" (append *standard-library* stmts))) + ;; don't use the standard library for now + (format stream "~{~A~^~%~}" stmts)) stream) diff --git a/test/bitc.lisp b/test/bitc.lisp index ece472807..019a29d2a 100644 --- a/test/bitc.lisp +++ b/test/bitc.lisp @@ -19,8 +19,7 @@ (define-test vampir-converter :parent geb-bitc - (of-type geb.vampir.spec:alias test-circuit-1)) - + (of-type list test-circuit-1)) (define-test bitc-evaluates-and-correctly :parent geb-bitc diff --git a/test/geb-trans.lisp b/test/geb-trans.lisp new file mode 100644 index 000000000..f814cc8b9 --- /dev/null +++ b/test/geb-trans.lisp @@ -0,0 +1,20 @@ +(in-package :geb-test) + +(define-test geb.trans :parent geb-test-suite) + +(def geb.pair-of-size-4 + (to-bitc + (pair (->right so1 bool) + (->left so1 bool)))) + +(define-test geb.trans-pair :parent geb.trans + (is = 4 (codom geb.pair-of-size-4) + "both objects have max size of 2, pair them size 4") + (is = 1 (dom geb.pair-of-size-4) + "Our input is bool, thus 1 bit") + (is obj-equalp #*1100 (gapply geb.pair-of-size-4 #*1) + "Right should tag it with 1, with our 1 injected and our left should + always be 00") + (is obj-equalp #*1000 (gapply geb.pair-of-size-4 #*0) + "Right should tag it with 1, with our 0 injected and our left should + always be 00")) diff --git a/test/geb.lisp b/test/geb.lisp index a6bf6e9f8..5522868cc 100644 --- a/test/geb.lisp +++ b/test/geb.lisp @@ -66,39 +66,37 @@ (->left so1 so1))) "Checking the dom of pair") (is obj-equalp - (prod geb-bool:bool - geb-bool:bool) + (prod bool + bool) (codom (pair (->left geb-bool:false-obj geb-bool:true-obj) (->left geb-bool:false-obj geb-bool:true-obj))) "Checking the codom of pair") (is obj-equalp - (dom (<-left so1 geb-bool:bool)) - (prod so1 geb-bool:bool) + (dom (<-left so1 bool)) + (prod so1 bool) "checking dom of projection") (is obj-equalp - (dom (distribute geb-bool:bool so1 so1)) - (prod geb-bool:bool (coprod so1 so1)) + (dom (distribute bool so1 so1)) + (prod bool (coprod so1 so1)) "checking dom of distribution") (is obj-equalp - (codom (distribute geb-bool:bool so1 so1)) - (coprod (prod geb-bool:bool so1) - (prod geb-bool:bool so1)) + (codom (distribute bool so1 so1)) + (coprod (prod bool so1) + (prod bool so1)) "checking codom of distribution")) (define-test curry :parent geb - (of-type substmorph (curry (<-left geb-bool:bool geb-bool:bool))) + (of-type substmorph (curry (<-left bool bool))) ;; may be typing this a bit too strictly - (of-type comp (curry (<-left geb-bool:bool so1))) - (is obj-equalp - (dom (geb:curry geb-bool:and)) - geb-bool:bool)) + (of-type comp (curry (<-left bool so1))) + (is obj-equalp (dom (geb:curry bool:and)) bool)) (define-test geb-trans :parent geb) -(def test-morph-2 (<-left so1 geb-bool:bool)) +(def test-morph-2 (<-left so1 bool)) (def test-poly-2 (to-poly test-morph-2)) @@ -108,42 +106,25 @@ (define-test vampir-test-2 :parent geb-trans - (of-type geb.vampir.spec:alias test-circuit-2)) + (of-type list test-circuit-2)) (define-test geb-interpreter :parent geb) ;; PLEASE FUZZ THIS! (define-test interpret-bool :parent geb-interpreter - (is - obj-equalp - (gapply geb-bool:and - (list (left so1) - (left so1))) - (left so1)) - - (is - obj-equalp - (gapply geb-bool:and - (list (left so1) - (right so1))) - (left so1)) - - (is - obj-equalp - (gapply geb-bool:and - (list (right so1) - (right so1))) - (right so1)) - - (is - obj-equalp - (gapply geb-bool:not - (left so1)) - (right so1)) - - (is - obj-equalp - (gapply geb-bool:not - (right so1)) - (left so1))) + (is obj-equalp + (gapply bool:and (list (left so1) (left so1))) + (left so1)) + + (is obj-equalp + (gapply bool:and (list (left so1) (right so1))) + (left so1)) + + (is obj-equalp + (gapply bool:and (list (right so1) (right so1))) + (right so1)) + + (is obj-equalp (gapply bool:not (left so1)) (right so1)) + + (is obj-equalp (gapply bool:not (right so1)) (left so1))) diff --git a/test/gui/graphing.lisp b/test/gui/graphing.lisp index c8303fe7c..314ce4d3d 100644 --- a/test/gui/graphing.lisp +++ b/test/gui/graphing.lisp @@ -38,11 +38,14 @@ :from geb-bool:bool :note "π₂") nil))))) - (is = + (format t "~A ~A" population (hash-table-count (geb.mixins::meta node))) + (is >= + ;; with how it works now it's actually 5! but we just need to + ;; check for 2 (+ 2 population) (hash-table-count (geb.mixins::meta node)) "By inserting these nodes we should have increased the - hashtable by two slots") + hashtable by at least two slots") (is equalp (~> node-merge-1 diff --git a/test/lambda-conversion.lisp b/test/lambda-conversion.lisp deleted file mode 100644 index 0a12ffd21..000000000 --- a/test/lambda-conversion.lisp +++ /dev/null @@ -1,134 +0,0 @@ -(in-package :geb-test) - -(define-test geb.lambda.trans - :parent geb-test-suite) - -(def bool geb-bool:bool) - -(def so-void-type - geb:so0) - -(def so-unit-type - geb:so1) - -(def stlc-unit-term - geb.lambda.spec:unit) - -(def so-unit-term - (geb:terminal so-unit-type)) - -(def unit-to-bool-left-circuit - (lambda:to-circuit - nil bool - (lambda:left so-unit-type so-unit-type stlc-unit-term) - :tc_unit_to_bool_left)) - -(def unit-to-bool-right-circuit - (lambda:to-circuit - nil bool - (lambda:right so-unit-type so-unit-type stlc-unit-term) - :tc_unit_to_bool_right)) - -(def pair-bool-stlc - (lambda:pair bool bool - (lambda:right so-unit-type so-unit-type stlc-unit-term) - (lambda:left so-unit-type so-unit-type stlc-unit-term))) - -(def pair-bool-circuit - (lambda:to-circuit - nil (geb:prod bool bool) - (lambda:pair bool bool - (lambda:right so-unit-type so-unit-type stlc-unit-term) - (lambda:left so-unit-type so-unit-type stlc-unit-term)) - :tc_pair_bool)) - -(def fst-bool-circuit - (lambda:to-circuit - nil bool - (lambda:fst bool bool pair-bool-stlc) - :tc_fst_bool)) - -(def unit-to-unit-circuit - (lambda:to-circuit nil so-unit-type stlc-unit-term :tc_unit_to_unit)) - -(def void-to-unit-circuit - (lambda:to-circuit - (list so-void-type) so-unit-type - (lambda:absurd so-unit-type (lambda:index 0)) :tc_void_to_unit)) - -(def issue-58-circuit - (lambda:to-circuit - nil - (coprod so-unit-type so-unit-type) - (lambda:case-on - so-unit-type so-unit-type - (coprod so-unit-type so-unit-type) - (lambda:left so-unit-type so-unit-type stlc-unit-term) - (lambda:lamb - so-unit-type (coprod so-unit-type so-unit-type) - (lambda:right so-unit-type so-unit-type stlc-unit-term)) - (lambda:lamb - so-unit-type (coprod so-unit-type so-unit-type) - (lambda:left so-unit-type so-unit-type stlc-unit-term)) - ) - :tc_issue_58)) - -(define-test compile-checked-term :parent geb.lambda.trans - (is obj-equalp - (lambda:compile-checked-term nil so-unit-type stlc-unit-term) - so-unit-term - "compile unit")) - -(define-test stlc-ctx-to-mu :parent compile-checked-term - (is equalp - (lambda:stlc-ctx-to-mu nil) - geb:so1 - "compile in a nil context")) - -(define-test fold-singleton-unit-context :parent compile-checked-term - (is obj-equalp - (lambda:stlc-ctx-to-mu (list geb:so1)) - (geb:prod geb:so1 geb:so1) - "fold singleton unit context")) - -(define-test fold-singleton-bool-context :parent compile-checked-term - (is obj-equalp - (lambda:stlc-ctx-to-mu (list geb-bool:bool)) - (geb:prod geb-bool:bool geb:so1) - "fold singleton bool context")) - -(define-test fold-multi-object-context :parent compile-checked-term - (is obj-equalp - (lambda:stlc-ctx-to-mu (list geb-bool:bool geb:so0 geb:so1)) - (geb:prod geb-bool:bool (geb:prod geb:so0 (geb:prod geb:so1 geb:so1))) - "fold multi-object context")) - -(define-test so-hom-so1-so1 :parent compile-checked-term - (is equalp - (lambda:so-hom geb:so1 geb:so1) - geb:so1 - "compute hom(so1,so1)")) - -(define-test vampir-test-unit-to-unit - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias unit-to-unit-circuit)) - -(define-test vampir-test-void-to-unit - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias void-to-unit-circuit)) - -(define-test vampir-test-unit-to-bool-left - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias unit-to-bool-left-circuit)) - -(define-test vampir-test-unit-to-bool-right - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias unit-to-bool-right-circuit)) - -(define-test vampir-test-pair-bool - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias pair-bool-circuit)) - -(define-test vampir-test-issue-58 - :parent geb.lambda.trans - (of-type geb.vampir.spec:alias issue-58-circuit)) diff --git a/test/lambda-experimental.lisp b/test/lambda-experimental.lisp new file mode 100644 index 000000000..335587d78 --- /dev/null +++ b/test/lambda-experimental.lisp @@ -0,0 +1,37 @@ +(in-package :geb-test) + +(define-test geb.lambda.experimental :parent geb-test-suite) + +(def test-term '(lambda (x y z) (+ x y (lambda (a b c) (+ a b c z))))) + +(def curried-term + '(lambda x (lambda y (lambda z (+ x y (lambda a (lambda b (lambda c (+ a b c z))))))))) + +(def nameless-term + `(lambda nil + (lambda nil + (lambda nil + (+ ,(geb.lambda.experimental:make-index :depth 2) + ,(geb.lambda.experimental:make-index :depth 1) + (lambda nil + (lambda nil + (lambda nil + (+ ,(geb.lambda.experimental:make-index :depth 2) + ,(geb.lambda.experimental:make-index :depth 1) + ,(geb.lambda.experimental:make-index :depth 0) + ,(geb.lambda.experimental:make-index :depth 3)))))))))) + +(define-test curry-expands-properly + :parent geb.lambda.experimental + (is equalp (geb.lambda.experimental:curry-lambda test-term) + curried-term)) + +(define-test nameless-works-properly + :parent geb.lambda.experimental + (is equalp (geb.lambda.experimental:nameless curried-term) nameless-term)) + +(define-test mixin-works-well + :parent geb.lambda.experimental + (is obj-equalp + (geb.lambda.spec:pair (geb.lambda.spec:unit) (geb.lambda.spec:unit)) + (geb.lambda.spec:pair (geb.lambda.spec:unit) (geb.lambda.spec:unit)))) diff --git a/test/lambda-trans.lisp b/test/lambda-trans.lisp new file mode 100644 index 000000000..78ecef022 --- /dev/null +++ b/test/lambda-trans.lisp @@ -0,0 +1,211 @@ +(in-package :geb-test) + +(define-test geb.lambda.trans + :parent geb-test-suite) + +(def pair-bool-stlc + (lambda:pair + (lambda:right so1 (lambda:unit)) + (lambda:left so1 (lambda:unit)))) + +(def lambda-not-with-lambda + (lambda:lamb + (list (coprod so1 so1)) + (lambda:case-on (lambda:index 0) + (lambda:lamb (list so1) (lambda:right so1 (lambda:unit))) + (lambda:lamb (list so1) (lambda:left so1 (lambda:unit)))))) + +(def lambda-not-without-lambda + (lambda:lamb + (list (coprod so1 so1)) + (lambda:case-on (lambda:index 0) + (lambda:right so1 (lambda:unit)) + (lambda:left so1 (lambda:unit))))) + +(def proper-not + (lambda:lamb + (list (coprod so1 so1)) + (lambda:case-on (lambda:index 0) + (lambda:right so1 (lambda:index 0)) + (lambda:left so1 (lambda:index 0))))) + +(def lambda-pairing + (lambda:lamb (list geb-bool:bool) + (lambda:pair (lambda:right so1 (lambda:index 0)) + (lambda:left so1 (lambda:index 0))))) + +(def bool-id + (lambda:lamb (list (coprod so1 so1)) (geb.lambda:index 0))) + +(def case-error-left + (lambda:case-on (lambda:left so1 (lambda:unit)) + (lambda:err so1) + (lambda:unit))) + +(def case-error-right + (lambda:case-on (lambda:left so1 (lambda:unit)) + (lambda:unit) + (lambda:err so1))) + +(def case-error-top + (lambda:case-on (lambda:err (coprod so1 so1)) + (lambda:unit) + (lambda:unit))) + +(def context-dependent-case + (lambda:case-on (lambda:index 0) + (lambda:err so1) + (lambda:unit))) + +(def issue-58-circuit + (to-circuit + (lambda:case-on + (lambda:left so1 (lambda:unit)) + (lambda:lamb (list so1) (lambda:right so1 (lambda:unit))) + (lambda:lamb (list so1) (lambda:left so1 (lambda:unit)))) + :tc_issue_58)) + +(defparameter *issue-94-circuit* + (lambda:app (lambda:lamb (list (lambda:fun-type + (lambda:fun-type (coprod so1 so1) + (coprod so1 so1)) + (coprod so1 so1))) + (lambda:app (lambda:index 0) + (list (lambda:lamb (list (coprod so1 so1)) + (lambda:index 0))))) + (list (lambda:lamb (list (lambda:fun-type (coprod so1 so1) + (coprod so1 so1))) + (lambda:left so1 (lambda:unit)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interpreter tests ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test lambda.trans-eval :parent geb.lambda.trans) + +(define-test lambda.case-works-as-expected :parent lambda.trans-eval + (is equalp #*0 (gapply (to-bitc lambda-not-with-lambda) #*1)) + (is equalp #*1 (gapply (to-bitc lambda-not-with-lambda) #*0)) + (is equalp + (gapply (to-bitc lambda-not-without-lambda) #*0) + (gapply (to-bitc lambda-not-with-lambda) #*0)) + (is equalp + (gapply (to-bitc lambda-not-without-lambda) #*1) + (gapply (to-bitc lambda-not-with-lambda) #*1))) + +(define-test lambda.preserves-pair :parent lambda.trans-eval + (is obj-equalp + (list (right (right so1)) + (left (right so1))) + (gapply (to-cat nil lambda-pairing) (list (right so1) so1)))) + + +(define-test gapply-bool-id :parent lambda.trans-eval + (is obj-equalp + (right so1) + (gapply + (to-cat nil bool-id) + (list (right so1) so1))) + (is obj-equalp + (left so1) + (gapply + (to-cat nil bool-id) + (list (left so1) so1))) + (is obj-equalp #*0 (gapply (to-bitc bool-id) #*0)) + (is obj-equalp #*1 (gapply (to-bitc bool-id) #*1))) + +(define-test lambda.not-works :parent lambda.trans-eval + (is obj-equalp (left so1) (gapply (to-cat nil proper-not) + (list (geb:right so1) so1))) + (is obj-equalp (right so1) (gapply (to-cat nil proper-not) + (list (geb:left so1) so1))) + (is equalp #*0 (gapply (to-bitc proper-not) #*1)) + (is equalp #*1 (gapply (to-bitc proper-not) #*0))) + +(define-test error-handling-case :parent lambda.trans-eval + (is obj-equalp (left so1) (gapply (to-cat nil case-error-left) + (list so1))) + (is obj-equalp (right so1) (gapply (to-cat nil case-error-right) + (list so1))) + (is obj-equalp (left so1) (gapply (to-cat nil case-error-top) + (list so1))) + (is obj-equalp (left so1) (gapply (to-cat (list (coprod so1 so1)) + context-dependent-case) + (list (right + (left + (right so1))) + so1))) + (is obj-equalp (right so1) (gapply (to-cat (list (coprod so1 so1)) + context-dependent-case) + (list (right + (right + (right so1))) + so1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile checked term tests ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test compile-checked-term :parent geb.lambda.trans + (is obj-equalp + (to-cat nil (lambda:unit)) + (geb:terminal so1) + "compile unit")) + +(define-test stlc-ctx-to-mu :parent compile-checked-term + (is equalp + (lambda:stlc-ctx-to-mu nil) + so1 + "compile in a nil context")) + +(define-test fold-singleton-unit-context :parent compile-checked-term + (is obj-equalp + (lambda:stlc-ctx-to-mu (list so1)) + (prod so1 so1) + "fold singleton unit context")) + +(define-test fold-singleton-bool-context :parent compile-checked-term + (is obj-equalp + (lambda:stlc-ctx-to-mu (list geb-bool:bool)) + (prod geb-bool:bool so1) + "fold singleton bool context")) + +(define-test fold-multi-object-context :parent compile-checked-term + (is obj-equalp + (lambda:stlc-ctx-to-mu (list geb-bool:bool so0 so1)) + (prod geb-bool:bool (prod so0 (prod so1 so1))) + "fold multi-object context")) + +(define-test so-hom-so1-so1 :parent compile-checked-term + (is equalp + (lambda:so-hom so1 so1) + so1 + "compute hom(so1,so1)")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Vampir Extractions Tests ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; vampir extraction tests, make better tests please. + +(define-test lambda-vampir-test :parent geb.lambda.trans + (of-type list (to-circuit + (lambda:left so1 (lambda:unit)) + :tc_unit_to_bool_left)) + (of-type list (to-circuit + (lambda:right so1 (lambda:unit)) + :tc_unit_to_bool_right)) + (of-type list (to-circuit (lambda:fst pair-bool-stlc) :tc_fst_bool)) + (of-type list (to-circuit (lambda:unit) :tc_unit_to_unit)) + (of-type list (to-circuit (to-cat (list so0) + (lambda:absurd so1 (lambda:index 0))) + :tc_void_to_unit)) + (of-type list issue-58-circuit)) + +(define-test issue-94-compiles :parent geb.lambda.trans + (parachute:finish + (geb.entry:compile-down :stlc t + :entry "geb-test::*issue-94-circuit*" + :stream nil))) diff --git a/test/lambda.lisp b/test/lambda.lisp index c123fe9ff..7fc97efae 100644 --- a/test/lambda.lisp +++ b/test/lambda.lisp @@ -1,37 +1,276 @@ (in-package :geb-test) -(define-test geb.lambda.experimental :parent geb-test-suite) - -(def test-term '(lambda (x y z) (+ x y (lambda (a b c) (+ a b c z))))) - -(def curried-term - '(lambda x (lambda y (lambda z (+ x y (lambda a (lambda b (lambda c (+ a b c z))))))))) - -(def nameless-term - `(lambda nil - (lambda nil - (lambda nil - (+ ,(geb.lambda.experimental:make-index :depth 2) - ,(geb.lambda.experimental:make-index :depth 1) - (lambda nil - (lambda nil - (lambda nil - (+ ,(geb.lambda.experimental:make-index :depth 2) - ,(geb.lambda.experimental:make-index :depth 1) - ,(geb.lambda.experimental:make-index :depth 0) - ,(geb.lambda.experimental:make-index :depth 3)))))))))) - -(define-test curry-expands-properly - :parent geb.lambda.experimental - (is equalp (geb.lambda.experimental:curry-lambda test-term) - curried-term)) - -(define-test nameless-works-properly - :parent geb.lambda.experimental - (is equalp (geb.lambda.experimental:nameless curried-term) nameless-term)) - -(define-test mixin-works-well - :parent geb.lambda.experimental - (is obj-equalp - (geb.lambda.spec:pair so1 so1 so1 so1) - (geb.lambda.spec:pair so1 so1 so1 so1))) +(define-test geb.lambda + :parent geb-test-suite) + +(def unit-term + (lambda:unit)) + +(def pair-of-units-term + (lambda:pair unit-term unit-term)) + +(def fst-pair-of-units-term + (lambda:fst pair-of-units-term)) + +(def snd-pair-of-units-term + (lambda:snd pair-of-units-term)) + +(def right-inj + (lambda:right so0 unit-term)) + +(def left-inj + (lambda:left so0 unit-term)) + +(def pair-of-injs + (lambda:pair right-inj + left-inj)) + +(def on-l-r-term + (lambda:case-on left-inj right-inj right-inj)) + +(def so01-coprod + (coprod so0 so1)) + +(def so10-coprod + (coprod so1 so0)) + +(def so1-prod + (prod so1 so1)) + +(def lamb-term + (lambda:lamb (list so1-prod) unit-term)) + +(def multi-lamb-term + (lambda:lamb (list so1 so0) (lambda:index 0))) + +(def multi-lambterm-type + (lambda:type-of-term-w-fun nil multi-lamb-term)) + +(def app-term + (lambda:app lamb-term (list pair-of-units-term))) + +(def multi-app-term + (lambda:app multi-lamb-term (list (lambda:index 0) (lambda:index 1)))) + +(def context-list + (list so1 so0 so01-coprod (geb.lambda.main:fun-type so0 so1))) + +(define-test type-of-unit-term-test + :parent geb.lambda + (is obj-equalp + so1 + (lambda:type-of-term nil unit-term) + "type of unit is so1")) + +(define-test type-of-pair-terms-test + :parent geb.lambda + (is obj-equalp + so1-prod + (lambda:type-of-term nil pair-of-units-term) + "type of product of units is product of so1's") + (is obj-equalp + so1 + (lambda:type-of-term + nil + (lambda:ltm (lambda:annotated-term nil pair-of-units-term))) + "type of the left unit term is so1") + (is obj-equalp + so1 + (lambda:type-of-term + nil + (lambda:rtm (lambda:annotated-term nil pair-of-units-term))))) + +(define-test fst-unit-term-test + :parent geb.lambda + (is obj-equalp + so1 + (lambda:type-of-term nil fst-pair-of-units-term) + "type of the projection from (prod so1 so1) is so1") + (is obj-equalp + so1-prod + (lambda:type-of-term + nil + (lambda:term (lambda:annotated-term nil fst-pair-of-units-term))) + "type of the term being projected is (prod so1 so1)")) + +(define-test snd-unit-term-test + :parent geb.lambda + (is obj-equalp + so1 + (lambda:type-of-term nil snd-pair-of-units-term) + "type of the projection from (prod so1 so1) is so1") + (is obj-equalp + so1-prod + (lambda:type-of-term + nil + (lambda:term (lambda:annotated-term nil snd-pair-of-units-term))) + "type of the term being projected is (prod so1 so1)")) + +(define-test proj-term-test + :parent geb.lambda + (is obj-equalp + (prod so01-coprod so10-coprod) + (lambda:type-of-term nil pair-of-injs) + "type of a pair of injection is a product of coproducts") + (is obj-equalp + so01-coprod + (lambda:type-of-term nil + (lambda:ltm + (lambda:annotated-term nil pair-of-injs))) + "test type annotation for the left term") + (is obj-equalp + so10-coprod + (lambda:type-of-term nil + (lambda:rtm + (lambda:annotated-term nil pair-of-injs))) + "test type annotation for the right term")) + + +(define-test casing-test + :parent geb.lambda + (is obj-equalp + so01-coprod + (lambda:type-of-term nil on-l-r-term) + "type of term gotten from the casing") + (is obj-equalp + so01-coprod + (lambda:type-of-term nil + (lambda:ltm + (lambda:annotated-term nil on-l-r-term))) + "test type annotation for left term") + (is obj-equalp + so01-coprod + (lambda:type-of-term nil + (lambda:rtm + (lambda:annotated-term nil on-l-r-term))) + "test type annotation for right term") + (is obj-equalp + so10-coprod + (lambda:type-of-term nil + (lambda:on + (lambda:annotated-term nil on-l-r-term))) + "type of annotated term supplied for the start of casing is that + of the supplied coproduct")) + +(define-test inl-test + :parent geb.lambda + (is obj-equalp + so01-coprod + (lambda:type-of-term nil right-inj) + "type of injection is a coproduct") + (is obj-equalp + so1 + (lambda:type-of-term nil + (lambda:term + (lambda:annotated-term nil right-inj))) + "test of the type of the annotated right term")) + +(define-test inr-test + :parent geb.lambda + (is obj-equalp + so10-coprod + (lambda:type-of-term nil left-inj) + "type of injection is a coproduct") + (is obj-equalp + so1 + (lambda:type-of-term nil + (lambda:term + (lambda:annotated-term nil left-inj))) + "test of the type of the annotated left term")) + +(define-test lamb-test + :parent geb.lambda + (is obj-equalp + (so-hom-obj so1-prod so1) + (lambda:type-of-term nil + lamb-term) + "test type of lambda term") + (is obj-equalp + so1 + (lambda:type-of-term nil + (lambda:term + (lambda:annotated-term nil + lamb-term))) + "test type of annotated term for the lambda term")) + +(define-test app-test + :parent geb.lambda + (is obj-equalp + so1 + (lambda:type-of-term nil (lambda:app lamb-term (list pair-of-units-term))) + "type of function application term") + (is obj-equalp + (so-hom-obj so1-prod so1) + (lambda:type-of-term nil + (lambda:fun + (lambda:annotated-term nil + app-term))) + "test annotated fun term") + (is obj-equalp + so1-prod + (lambda:type-of-term nil + (car (lambda:term + (lambda:annotated-term nil + app-term)))))) + +(define-test index-tests + :parent geb.lambda + (is obj-equalp + so1 + (lambda:type-of-term context-list (lambda:index 0))) + (is obj-equalp + so0 + (lambda:type-of-term context-list (lambda:index 1))) + (is obj-equalp + so01-coprod + (lambda:type-of-term context-list (lambda:index 2))) + (is obj-equalp + (so-hom-obj so0 so1) + (lambda:type-of-term context-list (lambda:index 3)))) + + +(define-test absurd-index-test + :parent geb.lambda + (is obj-equalp + so0 + (lambda:type-of-term + context-list + (lambda:term (lambda:annotated-term context-list + (lambda:absurd so1 (lambda:index 1))))))) + +(define-test exp-hom-test + :parent geb.lambda + (is obj-equalp + (so-hom-obj (coprod so0 (so-hom-obj so1 so1)) + (prod so1 (so-hom-obj so0 so1))) + (lambda:type-of-term + nil + (lambda:fun + (lambda:app (lambda:lamb + (list (coprod so0 (geb.lambda.main:fun-type so0 so1))) + (lambda:pair + unit-term + (lambda:lamb (list so1) + (lambda:lamb (list so0) + (lambda:index 0))))) + (list (lambda:right so0 + (lambda:lamb (list so1) unit-term)))))))) + +(define-test multi-lambda-test + :parent geb.lambda + (is obj-equalp + so1 + (mcadr multi-lambterm-type)) + (is obj-equalp + (prod so1 so0) + (mcar multi-lambterm-type))) + +(define-test multi-app-term + (is obj-equalp + so1 + (lambda:type-of-term (list so1 so0) multi-app-term)) + (is obj-equalp + (prod so1 so0) + (mcar (lambda:fun (lambda:ann-term1 (list so1 so0) multi-app-term))))) + + diff --git a/test/list.lisp b/test/list.lisp new file mode 100644 index 000000000..59549d8fe --- /dev/null +++ b/test/list.lisp @@ -0,0 +1,38 @@ +(in-package :geb-test) + +(define-test geb-list :parent geb-test-suite) + +(define-test cons-car-work + :parent geb-list + (is obj-equalp + (gapply (comp list:*car* list:*cons*) + (list (right bool:true-obj) + (left list:*nil*))) + (right bool:true-obj))) + + +(def list-empty-check + (comp + (mcase bool:true + (comp bool:false (terminal list:*cons-type*))) + list:*cdr* + list:*cons*)) + +(define-test cons-cdr-with-nil-gives-nil + :parent geb-list + (is obj-equalp + (gapply list-empty-check + (list (right bool:true-obj) + (left list:*nil*))) + ;; we check for true! + (right bool:true-obj))) + +(define-test cons-cdr-with-cons-gives-non-empty + :parent geb-list + (is obj-equalp + (gapply list-empty-check + (list (right bool:true-obj) + (right (list (right bool:true-obj) + (left list:*nil*))))) + ;; we check for false + (left bool:false-obj))) diff --git a/test/meta.lisp b/test/meta.lisp index 9a1c52232..ad2580f34 100644 --- a/test/meta.lisp +++ b/test/meta.lisp @@ -9,6 +9,11 @@ (meta-insert obj :a 2) (is = (meta-lookup obj :a) 2))) +(define-test copying-meta-data-works :parent geb-meta + (let ((obj (make-instance 'mixin-test))) + (meta-insert obj :a 2) + (is = (meta-lookup (geb.utils:copy-instance obj) :a) 2))) + #+nil (define-test weak-pointers-work :parent geb-meta (tg:gc :full t) diff --git a/test/package.lisp b/test/package.lisp index 229c7a564..f5ed6cd96 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -3,7 +3,10 @@ (:shadowing-import-from :parachute :name) (:shadowing-import-from :serapeum :true) (:shadow :value :children) + (:import-from #:geb-bool #:bool) (:local-nicknames (#:poly #:geb.poly) + (#:list #:geb-list) + (#:bool #:geb-bool) (#:bitc #:geb.bitc) (#:lambda #:geb.lambda)) (:use #:geb.common #:parachute)) diff --git a/test/pipeline.lisp b/test/pipeline.lisp index d4b4ce7f7..9bf5b64c8 100644 --- a/test/pipeline.lisp +++ b/test/pipeline.lisp @@ -3,16 +3,13 @@ (define-test geb-pipeline :parent geb-test-suite) (def test-compilation-eval-2 - (lambda:typed geb.lambda.spec:unit geb:so1)) + (geb.lambda.spec:unit)) (defparameter *entry* - (lambda:typed - (lambda:app (coprod so1 so1) - (coprod so1 so1) - (lambda:lamb (coprod so1 so1) (coprod so1 so1) (lambda:index 0)) - (lambda:left (coprod so1 so1) (coprod so1 so1) lambda:unit)) - (coprod so1 so1))) + (lambda:app + (lambda:lamb (list (coprod so1 so1)) (lambda:index 0)) + (list (lambda:left so1 (lambda:unit))))) (define-test pipeline-works-for-stlc-to-vampir :parent geb-pipeline diff --git a/test/poly.lisp b/test/poly.lisp index 63d3f7489..afca1fd71 100644 --- a/test/poly.lisp +++ b/test/poly.lisp @@ -15,8 +15,8 @@ (define-test poly-vampir-converter :parent geb-poly - (of-type geb.vampir.spec:alias test-circuit-1) - (of-type geb.vampir.spec:alias test-circuit-2)) + (of-type list test-circuit-1) + (of-type list test-circuit-2)) (define-test poly-interpreter :parent geb-poly) diff --git a/test/run-tests.lisp b/test/run-tests.lisp index d52dab58b..4682ecfc5 100644 --- a/test/run-tests.lisp +++ b/test/run-tests.lisp @@ -1,7 +1,7 @@ (in-package :geb-test) (defparameter *all-tests* - (list 'geb 'geb.lambda 'geb.lambda-conversion)) + (list 'geb 'geb.lambda 'geb.lambda-experimental 'geb.lambda-conversion)) ;; This just dumps the interactive information doesn't prompt you (defclass noisy-interactive (plain interactive) @@ -96,9 +96,10 @@ simply run this function to generate a fresh one (ccl:get-incremental-coverage)) (mapc (lambda (test) (run-tests :summary? t :designators test) - (setf (gethash test coverage) - (ccl:get-incremental-coverage))) - (children (find-test 'geb-test-suite))) + (when test + (setf (gethash test coverage) + (ccl:get-incremental-coverage)))) + (parachute:children (find-test 'geb-test-suite))) (ccl:report-coverage (if path ;; this is bad by god fix (format nil "~Areport.html" path)