Showing preview only (201K chars total). Download the full file or copy to clipboard to get everything.
Repository: VictorTaelin/Symmetric-Interaction-Calculus
Branch: main
Commit: e9f0185682ba
Files: 24
Total size: 191.8 KB
Directory structure:
gitextract_yzn1vp8o/
├── .gitignore
├── CLAUDE.md
├── Makefile
├── README.md
├── examples/
│ ├── test_0.ic
│ ├── test_1.ic
│ ├── test_2.ic
│ ├── test_3.ic
│ ├── test_4.ic
│ └── test_5.ic
├── haskell/
│ ├── main.hs
│ ├── main_debug.hs
│ └── modern_version.hs
└── src/
├── collapse.c
├── collapse.h
├── ic.c
├── ic.h
├── ic.metal
├── ic_metal.mm
├── main.c
├── parse.c
├── parse.h
├── show.c
└── show.h
================================================
FILE CONTENTS
================================================
================================================
FILE: .gitignore
================================================
.tmp/
bin/
obj/
# Compiled Object files
*.o
*.ko
*.obj
*.elf
# Compiled Dynamic libraries
*.so
*.dylib
*.dll
# Compiled Static libraries
*.a
*.la
*.lai
*.lib
# Backups
*.bak
# Executables
*.exe
*.out
*.app
*.i*86
*.x86_64
*.hex
# Debug files
*.dSYM/
*.su
*.idb
*.pdb
# Editor files
.vscode/
.idea/
*.swp
*~
# OS specific files
.DS_Store
.DS_Store?
._*
.Spotlight-V100
.Trashes
ehthumbs.db
Thumbs.db
old.c
task.txt
.fill.tmp
GOAL
up.sh
================================================
FILE: CLAUDE.md
================================================
# IC Project Guide
## Important Files
- `README.md` - Project Spec (ALWAYS READ IT)
- `src/main.c` - Program entry point (CLI)
- `src/ic.h` - The complete IC runtime
- `src/parse.[c|h]` - Term parsing
- `src/show.[c|h]` - Term stringification
## Build Commands
- Build the project: `make`
- Clean build artifacts: `make clean`
- Run with custom test term: `./bin/main "(λf.λx.(f (f (f x))) λb.(b λt.λf.f λt.λf.t) λt.λf.t)"`
## Code Style
- Use C99 standard with portable implementation
- Functions and variables should use `snake_case`
- Constants should be in `UPPER_CASE`
- Use 2 space indentation
================================================
FILE: Makefile
================================================
CC = gcc
CFLAGS = -w -std=c99 -O3 -march=native -mtune=native -flto
# Check for 64-bit mode flag
ifdef USE_64BIT
CFLAGS += -DIC_64BIT
endif
SRC_DIR = src
OBJ_DIR = obj
BIN_DIR = bin
# Metal GPU acceleration is the only supported GPU backend
# Check if we're on macOS for Metal support
UNAME := $(shell uname)
ifeq ($(UNAME), Darwin)
# Check if xcrun exists (required for Metal)
METAL_CHECK := $(shell which xcrun 2>/dev/null || echo "")
ifneq ($(METAL_CHECK),)
# Compile Metal on macOS
METAL_CFLAGS = -DHAVE_METAL
METAL_LDFLAGS = -framework Metal -framework Foundation -lc++
METAL_SRCS = $(SRC_DIR)/ic_metal.mm $(SRC_DIR)/ic.metal
METAL_OBJS = $(OBJ_DIR)/ic_metal.o
HAS_METAL = 1
# Use clang for Objective-C++ compilation
CXX = clang++
OBJCXX = clang++
OBJCXXFLAGS = -fobjc-arc -O3 -std=c++14
# Metal compiler
METAL_COMPILER = xcrun -sdk macosx metal
METAL_COMPILER_FLAGS = -O
METAL_OUTPUT = $(BIN_DIR)/ic.metallib
else
# No Metal available
METAL_SRCS =
METAL_OBJS =
METAL_CFLAGS =
METAL_LDFLAGS =
HAS_METAL = 0
endif
else
# Not macOS, no Metal
METAL_SRCS =
METAL_OBJS =
METAL_CFLAGS =
METAL_LDFLAGS =
HAS_METAL = 0
endif
# Main source files
SRCS = $(SRC_DIR)/main.c \
$(SRC_DIR)/ic.c \
$(SRC_DIR)/collapse.c \
$(SRC_DIR)/show.c \
$(SRC_DIR)/parse.c
# Parser is now included in the main source files
# Objects
OBJS = $(SRCS:$(SRC_DIR)/%.c=$(OBJ_DIR)/%.o)
# Executable
TARGET = $(BIN_DIR)/main
TARGET_LN = $(BIN_DIR)/ic
# Directories
DIRS = $(OBJ_DIR) $(BIN_DIR)
.PHONY: all clean status metal-status 64bit
all: $(DIRS) $(TARGET) $(TARGET_LN)
$(DIRS):
mkdir -p $@
# Build target with Metal or CPU-only
ifeq ($(HAS_METAL),1)
$(TARGET): $(OBJS) $(METAL_OBJS) $(METAL_OUTPUT)
$(CC) $(CFLAGS) -o $@ $(OBJS) $(METAL_OBJS) $(METAL_LDFLAGS)
else
$(TARGET): $(OBJS)
$(CC) $(CFLAGS) -o $@ $^
endif
$(TARGET_LN): $(TARGET)
ln -sf main $(TARGET_LN)
# Compile Metal shader library
$(METAL_OUTPUT): $(SRC_DIR)/ic.metal | $(BIN_DIR)
$(METAL_COMPILER) $(METAL_COMPILER_FLAGS) -o $@ $<
# Compile C files
ifeq ($(HAS_METAL),1)
$(OBJ_DIR)/%.o: $(SRC_DIR)/%.c
$(CC) $(CFLAGS) $(METAL_CFLAGS) -c -o $@ $<
else
$(OBJ_DIR)/%.o: $(SRC_DIR)/%.c
$(CC) $(CFLAGS) -c -o $@ $<
endif
# Compile Metal Objective-C++
ifeq ($(HAS_METAL),1)
$(OBJ_DIR)/ic_metal.o: $(SRC_DIR)/ic_metal.mm
$(OBJCXX) $(OBJCXXFLAGS) $(METAL_CFLAGS) -c -o $@ $<
endif
clean:
rm -rf $(OBJ_DIR) $(BIN_DIR)
# Show GPU acceleration status
status:
ifeq ($(HAS_METAL),1)
@echo "Metal supported on this system. Building with Metal GPU support."
else
@echo "No GPU acceleration available. Building CPU-only version."
endif
metal-status: $(TARGET)
@echo "Testing Metal availability..."
@./$(TARGET) eval-gpu "λx.x" 2>&1 | grep -i "Metal" || true
# 64-bit build target
64bit:
$(MAKE) USE_64BIT=1
================================================
FILE: README.md
================================================
# Interaction Calculus
The Interaction Calculus is a minimal term rewriting system inspired by the
Lambda Calculus (λC), but with some key differences that make it inherently more
efficient, in a way that closely resembles Lamping's optimal λ-calculus
evaluator, and more expressive, in some ways. In particular:
1. Vars are affine: they can only occur up to one time.
2. Vars are global: they can occur anywhere in the program.
3. It features first-class *superpositions* and *duplications*.
Global lambdas allow the IC to express concepts that aren't possible on the
traditional λC, including continuations, linear HOAS, and mutable references.
Superpositions and duplications allow the IC to be optimally evaluated, making
some computations exponentially faster. Finally, being fully affine makes its
garbage collector very efficient, and greatly simplifies parallelism.
The [HVM](https://github.com/HigherOrderCO/HVM3) is a fast, fully featured
implementation of this calculus.
**This repo now includes a reference implementation in C, which is also quite fast!**
**Now it also includes a single-file implementation in Haskell, great for learning!**
## Usage
This repository includes a reference implementation of the Interaction Calculus
in plain C, with some additional features, like native numbers. To install it:
```
make clean
make
```
Then, run one of the examples:
```
./bin/ic run examples/test_0.ic
```
For learning, edit the Haskell file: it is simpler, and has a step debugger.
## Specification
An IC term is defined by the following grammar:
```haskell
Term ::=
| VAR: Name
| ERA: "*"
| LAM: "λ" Name "." Term
| APP: "(" Term " " Term ")"
| SUP: "&" Label "{" Term "," Term "}"
| DUP: "!" "&" Label "{" Name "," Name "}" "=" Term ";" Term
```
Where:
- VAR represents a variable.
- ERA represents an erasure.
- LAM represents a lambda.
- APP represents a application.
- SUP represents a superposition.
- DUP represents a duplication.
Lambdas are curried, and work like their λC counterpart, except with a relaxed
scope, and with affine usage. Applications eliminate lambdas, like in λC,
through the beta-reduce (APP-LAM) interaction.
Superpositions work like pairs. Duplications eliminate superpositions through
the DUP-SUP interaction, which works exactly like a pair projection.
What makes SUPs and DUPs unique is how they interact with LAMs and APPs. When a
SUP is applied to an argument, it reduces through the APP-SUP interaction, and
when a LAM is projected, it reduces through the DUP-LAM interaction. This gives
a computational behavior for every possible interaction: there are no runtime
errors on the Interaction Calculus.
The 'Label' is just a numeric value. It affects the DUP-SUP interaction.
The core interaction rules are listed below:
```haskell
(* a)
----- APP-ERA
*
(λx.f a)
-------- APP-LAM
x <- a
f
(&L{a,b} c)
----------------- APP-SUP
! &L{c0,c1} = c;
&L{(a c0),(b c1)}
! &L{r,s} = *;
K
-------------- DUP-ERA
r <- *
s <- *
K
! &L{r,s} = λx.f;
K
----------------- DUP-LAM
r <- λx0.f0
s <- λx1.f1
x <- &L{x0,x1}
! &L{f0,f1} = f;
K
! &L{x,y} = &L{a,b};
K
-------------------- DUP-SUP (if equal labels)
x <- a
y <- b
K
! &L{x,y} = &R{a,b};
K
-------------------- DUP-SUP (if different labels)
x <- &R{a0,b0}
y <- &R{a1,b1}
! &L{a0,a1} = a;
! &L{b0,b1} = b;
K
```
Where `x <- t` stands for a global substitution of `x` by `t`.
Since variables are affine, substitutions can be implemented efficiently by just
inserting an entry in a global substitution map (`sub[var] = value`). There is
no need to traverse the target term, or to handle name capture, as long as fresh
variable names are globally unique. It can also be implemented in a concurrent
setup with a single atomic-swap.
Below is a pseudocode implementation of these interaction rules:
```python
def app_lam(app, lam):
sub[lam.nam] = app.arg
return lam.bod
def app_sup(app, sup):
x0 = fresh()
x1 = fresh()
a0 = App(sup.lft, Var(x0))
a1 = App(sup.rgt, Var(x1))
return Dup(sup.lab, x0, x1, app.arg, Sup(a0, a1))
def dup_lam(dup, lam):
x0 = fresh()
x1 = fresh()
f0 = fresh()
f1 = fresh()
sub[dup.lft] = Lam(x0, Var(f0))
sub[dup.rgt] = Lam(x1, Var(f1))
sub[lam.nam] = Sup(dup.lab, Var(x0), Var(x1))
return Dup(dup.lab, f0, f1, lam.bod, dup.bod)
def dup_sup(dup, sup):
if dup.lab == sup.lab:
sub[dup.lft] = sup.lft
sub[dup.rgt] = sup.rgt
return dup.bod
else:
a0 = fresh()
a1 = fresh()
b0 = fresh()
b1 = fresh()
sub[dup.lft] = Sup(sup.lab, Var(a0), Var(b0))
sub[dup.rgt] = Sup(sup.lab, Var(a1), Var(b1))
return Dup(dup.lab, a0, a1, sup.lft, Dup(dup.lab, b0, b1, sup.rgt, dup.bod))
```
Terms can be reduced to weak head normal form, which means reducing until the
outermost constructor is a value (LAM, SUP, etc.), or until no more reductions
are possible. Example:
```python
def whnf(term):
while True:
match term:
case Var(nam):
if nam in sub:
term = sub[nam]
else:
return term
case App(fun, arg):
fun = whnf(fun)
match fun.tag:
case Lam: term = app_lam(term, fun)
case Sup: term = app_sup(term, fun)
case _ : return App(fun, arg)
case Dup(lft, rgt, val, bod):
val = whnf(val)
match val.tag:
case Lam: term = dup_lam(term, val)
case Sup: term = dup_sup(term, val)
case _ : return Dup(lft, rgt, val, bod)
case _:
return term
```
Terms can be reduced to full normal form by recursively taking the whnf:
```python
def normal(term):
term = whnf(term)
match term:
case Lam(nam, bod):
bod_nf = normal(bod)
return Lam(nam, bod_nf)
case App(fun, arg):
fun_nf = normal(fun)
arg_nf = normal(arg)
return App(fun_nf, arg_nf)
...
case _:
return term
```
Below are some normalization examples.
Example 0: (simple λ-term)
```
(λx.λt.(t x) λy.y)
------------------ APP-LAM
λt.(t λy.y)
```
Example 1: (larger λ-term)
```
(λb.λt.λf.((b f) t) λT.λF.T)
---------------------------- APP-LAM
λt.λf.((λT.λF.T f) t)
----------------------- APP-LAM
λt.λf.(λF.t f)
-------------- APP-LAM
λt.λf.t
```
Example 2: (global scopes)
```
{x,(λx.λy.y λk.k)}
------------------ APP-LAM
{λk.k,λy.y}
```
Example 3: (superposition)
```
!{a,b} = {λx.x,λy.y}; (a b)
--------------------------- DUP-SUP
(λx.x λy.y)
----------- APP-LAM
λy.y
```
Example 4: (overlap)
```
({λx.x,λy.y} λz.z)
------------------ APP-SUP
! {x0,x1} = λz.z; {(λx.x x0),(λy.y x1)}
--------------------------------------- DUP-LAM
! {f0,f1} = {r,s}; {(λx.x λr.f0),(λy.y λs.f1)}
---------------------------------------------- DUP-SUP
{(λx.x λr.r),(λy.y λs.s)}
------------------------- APP-LAM
{λr.r,(λy.y λs.s)}
------------------ APP-LAM
{λr.r,λs.s}
```
Example 5: (default test term)
The following term can be used to test all interactions:
```
((λf.λx.!{f0,f1}=f;(f0 (f1 x)) λB.λT.λF.((B F) T)) λa.λb.a)
----------------------------------------------------------- 16 interactions
λa.λb.a
```
## Collapsing
An Interaction Calculus term can be collapsed to a superposed tree of pure
Lambda Calculus terms without SUPs and DUPs, by extending the evaluator with the
following collapse interactions:
```haskell
λx.*
------ ERA-LAM
x <- *
*
(f *)
----- ERA-APP
*
λx.&L{f0,f1}
----------------- SUP-LAM
x <- &L{x0,x1}
&L{λx0.f0,λx1.f1}
(f &L{x0,x1})
------------------- SUP-APP
!&L{f0,f1} = f;
&L{(f0 x0),(f1 x1)}
!&L{x0,x1} = x; K
----------------- DUP-VAR
x0 <- x
x1 <- x
K
!&L{a0,a1} = (f x); K
--------------------- DUP-APP
a0 <- (f0 x0)
a1 <- (f1 x1)
!&L{f0,f1} = f;
!&L{x0,x1} = x;
K
```
## DUP Permutations
These interactions move a nested DUP out of a redex position.
```
(!&L{k0,k1}=k;f x)
------------------ APP-DUP
!&L{k0,k1}=k;(f x)
! &L{x0,x1} = (!$R{y0,y1}=Y;X); T
------------------------------------- DUP-DUP
! &L{x0,x1} = X; ! &L{y0,y1} = Y; T
```
They're only needed in implementations that store a DUP's body.
## Labeled Lambdas
Another possible extension of IC is to include labels on lams/apps:
```haskell
| LAM: "&" Label "λ" Name "." Term
| APP: "&" Label "(" Term " " Term ")"
```
The APP-LAM rule must, then, be extended with:
```haskell
&L(&Rλx.bod arg)
----------------------- APP-LAM (if different labels)
x <- &Lλy.z
&Rλz.&L(body &R(arg y))
```
## IC = Lambda Calculus U Interaction Combinators
Consider the conventional Lambda Calculus, with pairs. It has two computational rules:
- Lambda Application : `(λx.body arg)`
- Pair Projection : `let {a,b} = {fst,snd} in cont`
When compiling the Lambda Calculus to Interaction Combinators:
- `lams` and `apps` can be represented as constructor nodes (γ)
- `pars` and `lets` can be represented as duplicator nodes (δ)
As such, lambda applications and pair projections are just annihilations:
```
Lambda Application Pair Projection
(λx.body arg) let {a,b} = {fst,snd} in cont
---------------- -----------------------------
x <- arg a <- fst
body b <- snd
cont
ret arg ret arg b a b a
| | | | | | | |
|___| | | |___| | |
app \ / \ / let \#/ \ /
| ==> \/ | ==> \/
| /\ | /\
lam /_\ / \ pair /#\ / \
| | | | | | | |
| | | | | | | |
x body x body fst snd fst snd
"The application of a lambda "The projection of a pair just
substitutes the lambda's var substitutes the projected vars
by the application's arg, and by each element of the pair, and
returns the lambda body." returns the continuation."
```
But annihilations only happen when identical nodes interact. On interaction
nets, it is possible for different nodes to interact, which triggers another rule,
the commutation. That rule could be seen as handling the following expressions:
- Lambda Projection : `let {a b} = (λx body) in cont`
- Pair Application : `({fst snd} arg)`
But how could we "project" a lambda or "apply" a pair? On the Lambda Calculus, these
cases are undefined and stuck, and should be type errors. Yet, by interpreting the
effects of the commutation rule on the interaction combinator point of view, we
can propose a reasonable reduction for these lambda expressions:
```
Lambda Application Pair Application
let {a,b} = (λx.body) in cont ({fst,snd} arg)
------------------------------ ---------------
a <- λx0.b0 let {x0,x1} = arg in
b <- λx1.b1 {(fst x0),(snd x1)}
x <- {x0,x1}
let {b0,b1} = body in
cont
ret arg ret arg ret arg ret arg
| | | | | | | |
|___| | | |___| | |
let \#/ /_\ /_\ app \ / /#\ /#\
| ==> | \/ | | ==> | \/ |
| |_ /\ _| | |_ /\ _|
lam /_\ \#/ \#/ pair /#\ \ / \ /
| | | | | | | |
| | | | | | | |
x body x body var body var body
"The projection of a lambda "The application of a pair is a pair
substitutes the projected vars of the first element and the second
by a copies of the lambda that element applied to projections of the
return its projected body, with application argument."
the bound variable substituted
by the new lambda vars paired."
```
This, in a way, completes the lambda calculus; i.e., previously "stuck"
expressions now have a meaningful computation. That system, as written, is
Turing complete, yet, it is very limited, since it isn't capable of cloning
pairs, or cloning cloned lambdas. There is a simple way to greatly increase its
expressivity, though: by decorating lets with labels, and upgrading the pair
projection rule to:
```haskell
let &i{a,b} = &j{fst,snd} in cont
---------------------------------
if i == j:
a <- fst
b <- snd
cont
else:
a <- &j{a0,a1}
b <- &j{b0,b1}
let &i{a0,a1} = fst in
let &i{b0,b1} = snd in
cont
```
That is, it may correspond to either an Interaction Combinator annihilation or
commutation, depending on the value of the labels `&i` and `&j`. This makes IC
capable of cloning pairs, cloning cloned lambdas, computing nested loops,
performing Church-encoded arithmetic up to exponentiation, expressing arbitrary
recursive functions such as the Y-combinators and so on. In other words, with
this simple extension, IC becomes extraordinarily powerful and expressive,
giving us a new foundation for symbolic computing, that is, in many ways, very
similar to the λ-Calculus, yet, with key differences that make it more
efficient in some senses, and capable of expressing new things (like call/cc,
O(1) queues, linear HOAS), but unable to express others (like `λx.(x x)`).
## IC32: a 32-Bit Runtime
IC32 is implemented in portable C.
Each Term is represented as a 32-bit word, split into the following fields:
- sub (1-bit): true if this is a substitution
- tag (5-bit): the tag identifying the term type and label
- val (26-bit): the value, typically a pointer to a node in memory
The tag field can be one of the following:
- `VAR`: 0x00
- `LAM`: 0x01
- `APP`: 0x02
- `ERA`: 0x03
- `NUM`: 0x04
- `SUC`: 0x05
- `SWI`: 0x06
- `TMP`: 0x07
- `SP0`: 0x08
- `SP1`: 0x09
- `SP2`: 0x0A
- `SP3`: 0x0B
- `SP4`: 0x0C
- `SP5`: 0x0D
- `SP6`: 0x0E
- `SP7`: 0x0F
- `CX0`: 0x10
- `CX1`: 0x11
- `CX2`: 0x12
- `CX3`: 0x13
- `CX4`: 0x14
- `CX5`: 0x15
- `CX6`: 0x16
- `CX7`: 0x17
- `CY0`: 0x18
- `CY1`: 0x19
- `CY2`: 0x1A
- `CY3`: 0x1B
- `CY4`: 0x1C
- `CY5`: 0x1D
- `CY6`: 0x1E
- `CY7`: 0x1F
The val field depends on the variant:
- `VAR`: points to a Lam node ({bod: Term}) or a substitution.
- `LAM`: points to a Lam node ({bod: Term}).
- `APP`: points to an App node ({fun: Term, arg: Term}).
- `ERA`: unused.
- `NUM`: stores an unsigned integer.
- `SUC`: points to a Suc node ({num: Term})
- `SWI`: points to a Swi node ({num: Term, ifZ: Term, ifS: Term})
- `SP{L}`: points to a Sup node ({lft: Term, rgt: Term}).
- `CX{L}`: points to a Dup node ({val: Term}) or a substitution.
- `CY{L}`: points to a Dup node ({val: Term}) or a substitution.
A node is a consecutive block of its child terms. For example, the SUP term
points to the memory location where its two child terms are stored.
Variable terms (`VAR`, `CX{L}`, and `CY{L}`) point to the location where the
substitution will be placed. As an optimization, that location is always the
location of the corresponding binder node (like a Lam or Dup). When the
interaction occurs, we replace the binder node by the substituted term, with the
'sub' bit set. Then, when we access it from a variable, we retrieve that term,
clearing the bit.
On SUPs and DUPs, the 'L' stands for the label of the corresponding node.
Note that there is no explicit DUP term. That's because Dup nodes are special:
they aren't part of the AST, and they don't store a body; they "float" on the
heap. In other words, `λx. !&0{x0,x1}=x; &0{x0,x1}` and `!&0{x0,x1}=x; λx.
&0{x0,x1}` are both valid, and stored identically in memory. As such, the only
way to access a Dup node is via its bound variables, `CX{L}` and `CY{L}`.
Before the interaction, the Dup node stores just the duplicated value (no body).
After a collapse is triggered (when we access it via a `CX{L}` or `CY{L}`
variable), the first half of the duplicated term is returned, and the other half
is stored where the Dup node was, allowing the other variable to get it as a
substitution. For example, the DUP-SUP interaction could be implemented as:
```python
def dup_sup(dup, sup):
dup_lab = dup.tag & 0x3
sup_lab = sup.tag & 0x3
if dup_lab == sup_lab:
tm0 = heap[sup.loc + 0]
tm1 = heap[sup.loc + 1]
heap[dup.loc] = as_sub(tm1 if (dup.tag & 0x4) == 0 else tm0)
return (tm0 if (dup.tag & 0x4) == 0 else tm1)
else:
co0_loc = alloc(1)
co1_loc = alloc(1)
su0_loc = alloc(2)
su1_loc = alloc(2)
su0_val = Term(SP0 + sup_lab, su0_loc)
su1_val = Term(SP0 + sup_lab, su1_loc)
heap[co0_loc] = heap[sup.loc + 0]
heap[co1_loc] = heap[sup.loc + 1]
heap[su0_loc + 0] = Term(CX0 + dup_lab, co0_loc)
heap[su0_loc + 1] = Term(CX0 + dup_lab, co1_loc)
heap[su1_loc + 0] = Term(CY0 + dup_lab, co0_loc)
heap[su1_loc + 1] = Term(CY0 + dup_lab, co1_loc)
heap[dup.loc] = as_sub(su1_val if (dup.tag & 0x4) == 0 else su0_val)
return (su0_val if (dup.tag & 0x4) == 0 else su1_val)
```
The NUM, SUC and SWI terms extend the IC with unboxed unsigned integers.
## Parsing IC32
On IC32, all bound variables have global range. For example, consider the term:
λt.((t x) λx.λy.y)
Here, the `x` variable appears before its binder, `λx`. Since runtime variables
must point to their bound λ's, linking them correctly requires caution. A way to
do it is to store two structures at parse-time:
1. lcs: an array from names to locations
2. vrs: a map from names to var terms
Whenever we parse a name, we add the current location to the 'uses' array, and
whenever we parse a binder (lams, lets, etc.), we add a variable term pointing
to it to the 'vars' map. Then, once the parsing is done, we run iterate through
the 'uses' array, and write, to each location, the corresponding term. Below
are some example parsers using this strategy:
```python
def parse_var(loc):
nam = parse_name()
uses.push((nam,loc))
def parse_lam(loc):
lam = alloc(1)
consume("λ")
nam = parse_name()
consume(".")
vars[nam] = Term(VAR, 0, lam)
parse_term(lam)
heap[loc] = Term(LAM, 0, lam)
def parse_app(loc):
app = alloc(2)
consume("(")
parse_term(app + 0)
consume(" ")
parse_term(app + 1)
consume(")")
heap[loc] = Term(APP, 0, app)
def parse_sup(loc):
sup = alloc(2)
consume("&")
lab = parse_uint()
consume("{")
lft = parse_term(sup + 0)
consume(",")
rgt = parse_term(sup + 1)
consume("}")
heap[loc] = Term(SUP, lab, sup)
def parse_dup(loc):
dup = alloc(1)
consume("!")
consume("&")
lab = parse_uint()
consume("{")
co0 = parse_name()
consume(",")
co1 = parse_name()
consume("}")
consume("=")
val = parse_term(dup)
bod = parse_term(loc)
vars[co0] = Term(DP0, lab, loc)
vars[co1] = Term(DP1, lab, loc)
```
## Stringifying IC32
Converting IC32 terms to strings faces two challenges:
First, IC32 terms and nodes don't store variable names. As such, we must
generate fresh, unique variable names during stringification, and maintain a
mapping from each binder's memory location to its assigned name.
Second, on IC32, Dup nodes aren't part of the main program's AST. Instead,
they "float" on the heap, and are only reachable via DP0 and DP1 variables.
Because of that, by stringifying a term naively, Col nodes will be missing.
To solve these, we proceed as follows:
1. Before stringifying, we pass through the full term, and assign a id to each
variable binder we find (on lam, let, dup, etc.)
2. We also register every Dup node we found, avoiding duplicates (remember the
same dup node is pointed to by up to 2 variables, DP0 and DP1)
Then, to stringify the term, we first stringify each DUP node, and then we
stringify the actual term. As such, the result will always be in the form:
```haskell
! &{x0 x1} = t0
! &{x2 x3} = t1
! &{x4 x5} = t2
...
term
```
With no Dup nodes inside the ASTs of t0, t1, t2 ... and term.
================================================
FILE: examples/test_0.ic
================================================
!P19 = λf.
!&0{f0,f1} = f;
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
!&0{f0,f1} = λx.(f0 (f1 x));
λx.(f0 (f1 x));
(P19 λnx.((nx λt0.λf0.f0) λt1.λf1.t1) λT.λF.T)
================================================
FILE: examples/test_1.ic
================================================
λf. λx. !&0{f0,f1}=f; (f0 (f1 x))
//&2{&1{&0{λa.a,λb.b},&0{λc.c,λd.d}},&1{&0{λe.e,λf.f},&0{λg.g,λh.h}}}
// _ O _
// / \
// _O_ _O_
// / | | \
// O O O O
// / \ / \ / \ / \
// O O O O O O O O
================================================
FILE: examples/test_2.ic
================================================
λt.(t λ$x.$y λ$y.$x)
// λx. !&0{x0,x1}=x; &0{(x0 λa.λb.a),(x1 λt.λf.f)}
// !&0{x0,x1}=&0{k0,k1}; &0{λk0.(x0 λa.a),λk1.(x1 λb.b)}
// !&0{x0,x1}=x; λx.&0{(x0 λa.a),(x1 λb.b)}
// -----------------------------------------------------
// !&0{x0,x1}=&0{k0,k1}; &0{λk0.(x0 λa.a),λk1.(x1 λb.b)}
// λx.&L{f0,f1}
// ----------------- SUP-LAM
// x <- &L{x0,x1}
// &L{λx0.f0,λx1.f1}
// CORRECT:
// λt.(t &0{λa.a,λb.b})
// !&0{t0,t1} = t; λt.&0{(t0 λa.a),(t1 λb.b)}
// !&0{t0,t1} = !&0{T0,T1}; &0{λT0.(t0 λa.a),λT1.(t1 λb.b)}
// &0{λT0.(T0 λa.a),λT1.(T1 λb.b)}
================================================
FILE: examples/test_3.ic
================================================
λf.λx.(f (f (f x)))
//! &0{a3,b4} = x0; (λx0.λx1.((x1 x0) b4) λx2.x2)
//!P19 = λf.
//!&0{f00x,f00y} = f;
//!&0{f01x,f01y} = λk01.(f00x (f00y k01));
//!&0{f02x,f02y} = λk02.(f01x (f01y k02));
//!&0{f03x,f03y} = λk03.(f02x (f02y k03));
//!&0{f04x,f04y} = λk04.(f03x (f03y k04));
//!&0{f05x,f05y} = λk05.(f04x (f04y k05));
//!&0{f06x,f06y} = λk06.(f05x (f05y k06));
//!&0{f07x,f07y} = λk07.(f06x (f06y k07));
//!&0{f08x,f08y} = λk08.(f07x (f07y k08));
//!&0{f09x,f09y} = λk09.(f08x (f08y k09));
//!&0{f10x,f10y} = λk10.(f09x (f09y k10));
//!&0{f11x,f11y} = λk11.(f10x (f10y k11));
//!&0{f12x,f12y} = λk12.(f11x (f11y k12));
//!&0{f13x,f13y} = λk13.(f12x (f12y k13));
//!&0{f14x,f14y} = λk14.(f13x (f13y k14));
//!&0{f15x,f15y} = λk15.(f14x (f14y k15));
//!&0{f16x,f16y} = λk16.(f15x (f15y k16));
//!&0{f17x,f17y} = λk17.(f16x (f16y k17));
//!&0{f18x,f18y} = λk18.(f17x (f17y k18));
//λk19.(f18x (f18y k19));
//((P19 λnx.((nx λt0.λf0.t0) λt1.λf1.f1)) λT.λF.T)
================================================
FILE: examples/test_4.ic
================================================
!Y = λf. !&1{f0,f1}=λx.!&1{x0,x1}=x;(f (x0 x1)); (f0 f1);
!true = λt. λf. t;
!false = λt. λf. f;
!not = λb. (b false true);
!neg = (Y λneg. λxs. (xs
λp.λo.λi.λe.(i (neg p))
λp.λo.λi.λe.(o (neg p))
λo.λi.λe.e));
!xs =
λo.λi.λe.(o
λo.λi.λe.(o
λo.λi.λe.(o
λo.λi.λe.(o
λo.λi.λe.e))));
(neg (neg (neg xs)))
================================================
FILE: examples/test_5.ic
================================================
// Test switch on superposition - test SUP-SWI-S interaction
λx.?x{0:0;+:&0{1,2};}
//!&0{a2,b3} = 0;
//&0{λa.?a{0:a2;+:1;},λb.?b{0:b3;+:2;}}
//!&0{a2,b3} = 0;
//&0{
//λa.?b{0:a2;+:1;},
//λb.?b{0:b3;+:2;}
//}
// ! &0{a1,b2} = 0;
// ! &0{x0,x1} = x;
// λx.&0{?x0{0:a1;+:1;},?x1{0:b2;+:2;}}
// ! &0{a1,b2} = 0;
// ! &0{x0,x1} = &0{k0,k1};
// &0{λk0.?x0{0:a1;+:1;},λk1.?x1{0:b2;+:2;}}
================================================
FILE: haskell/main.hs
================================================
-- Welcome to the Interaction Calculus Haskell reference implementation! :D This
-- file is very simple, and great for learning. It represents IC terms as native
-- Haskell ADTs, which is possible thanks to the DUP-DUP permutations.
{-# LANGUAGE MultilineStrings #-}
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (chr, ord)
import Data.IORef
import Data.Maybe (isJust)
import Data.Word
import Debug.Trace
import System.IO.Unsafe (unsafePerformIO)
import Text.Parsec hiding (State)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map as Map
import qualified Text.Parsec as Parsec
type Name = Word64
data Term
= Var Name -- Name
| Let Name Term Term -- "! " Name " = " Term "; " Term
| Era -- "*"
| Sup Name Term Term -- "&" Name "{" Term "," Term "}"
| Dup Name Name Name Term Term -- "! &" Name "{" Name "," Name "}" "=" Term ";" Term
| Lam Name Name Term -- "&" Label "λ" Name "." Term
| App Name Term Term -- "&" Label "(" Term " " Term ")"
-- Globals
-- -------
{-# NOINLINE gSUBST #-}
gSUBST :: IORef (IntMap.IntMap Term)
gSUBST = unsafePerformIO $ newIORef IntMap.empty
{-# NOINLINE gFRESH #-}
gFRESH :: IORef Name
gFRESH = unsafePerformIO $ newIORef 0
{-# NOINLINE gINTERS #-}
gINTERS :: IORef Word64
gINTERS = unsafePerformIO $ newIORef 0
-- Helper functions for global substitution
set :: Name -> Term -> IO ()
set name term = do
subMap <- readIORef gSUBST
writeIORef gSUBST (IntMap.insert (fromIntegral name) term subMap)
get :: Name -> IO (Maybe Term)
get name = do
subMap <- readIORef gSUBST
let result = IntMap.lookup (fromIntegral name) subMap
when (isJust result) $ do
let newMap = IntMap.delete (fromIntegral name) subMap
writeIORef gSUBST newMap
return result
fresh :: IO Name
fresh = do
n <- readIORef gFRESH
writeIORef gFRESH (n + 1)
return n
incInters :: IO ()
incInters = do
n <- readIORef gINTERS
writeIORef gINTERS (n + 1)
-- Evaluator
-- ---------
app_era :: Term -> Term -> IO Term
app_era Era _ = do
incInters
return Era
app_era _ _ = error "app_era: expected Era as first argument"
app_lam :: Term -> Term -> Name -> IO Term
app_lam (Lam lam_lab nam bod) arg app_lab = do
incInters
if lam_lab == app_lab then do
set nam arg
whnf bod
else do
y <- fresh
z <- fresh
set nam (Lam app_lab y (Var z))
whnf $ Lam lam_lab z (App app_lab bod (App lam_lab arg (Var y)))
app_lam _ _ _ = error "app_lam: expected Lam as first argument"
app_sup :: Term -> Term -> Name -> IO Term
app_sup (Sup lab lft rgt) arg app_lab = do
incInters
c0 <- fresh
c1 <- fresh
let a0 = App app_lab lft (Var c0)
let a1 = App app_lab rgt (Var c1)
whnf (Dup lab c0 c1 arg (Sup lab a0 a1))
app_sup _ _ _ = error "app_sup: expected Sup as first argument"
app_dup :: Term -> IO Term
app_dup (App app_lab f (Dup dup_lab x y val bod)) = do
incInters
whnf (Dup dup_lab x y val (App app_lab f bod))
app_dup term = error "app_dup: expected App with Dup"
dup_era :: Term -> Term -> IO Term
dup_era (Dup lab r s _ k) Era = do
incInters
set r Era
set s Era
whnf k
dup_era _ _ = error "dup_era: expected Dup and Era"
dup_lam :: Term -> Term -> IO Term
dup_lam (Dup lab r s _ k) (Lam lam_lab x f) = do
incInters
x0 <- fresh
x1 <- fresh
f0 <- fresh
f1 <- fresh
set r (Lam lam_lab x0 (Var f0))
set s (Lam lam_lab x1 (Var f1))
set x (Sup lab (Var x0) (Var x1))
whnf (Dup lab f0 f1 f k)
dup_lam _ _ = error "dup_lam: expected Dup and Lam"
dup_sup :: Term -> Term -> IO Term
dup_sup (Dup dupLab x y _ k) (Sup supLab a b) = do
incInters
if dupLab == supLab then do
set x a
set y b
whnf k
else do
a0 <- fresh
a1 <- fresh
b0 <- fresh
b1 <- fresh
set x (Sup supLab (Var a0) (Var b0))
set y (Sup supLab (Var a1) (Var b1))
whnf (Dup dupLab a0 a1 a (Dup dupLab b0 b1 b k))
dup_sup _ _ = error "dup_sup: expected Dup and Sup"
dup_dup :: Term -> Term -> IO Term
dup_dup (Dup labL x0 x1 _ t) (Dup labR y0 y1 y x) = do
incInters
whnf (Dup labL x0 x1 x (Dup labL y0 y1 y t))
dup_dup _ _ = error "dup_dup: expected Dup with inner Dup"
whnf :: Term -> IO Term
whnf term = case term of
Var n -> do
sub <- get n
case sub of
Just s -> do
whnf s
Nothing -> return (Var n)
Let x v b -> do
set x v
whnf b
App app_lab f a -> do
f' <- whnf f
case f' of
Lam {} -> app_lam f' a app_lab
Sup {} -> app_sup f' a app_lab
Era -> app_era f' a
Dup {} -> app_dup (App app_lab f' a)
_ -> return (App app_lab f' a)
Dup dup_lab r s v k -> do
v' <- whnf v
case v' of
Lam {} -> dup_lam (Dup dup_lab r s v' k) v'
Sup {} -> dup_sup (Dup dup_lab r s v' k) v'
Era -> dup_era (Dup dup_lab r s v' k) v'
Dup {} -> dup_dup (Dup dup_lab r s v' k) v'
_ -> return (Dup dup_lab r s v' k)
_ -> return term
normal :: Term -> IO Term
normal term = do
term_whnf <- whnf term
case term_whnf of
Var n -> do
return (Var n)
Era -> do
return Era
Lam lab n body -> do
body_norm <- normal body
return (Lam lab n body_norm)
App lab fun arg -> do
fun_norm <- normal fun
arg_norm <- normal arg
return (App lab fun_norm arg_norm)
Sup lab lft rgt -> do
lft_norm <- normal lft
rgt_norm <- normal rgt
return (Sup lab lft_norm rgt_norm)
Dup lab r s v k -> do
v_norm <- normal v
k_norm <- normal k
return (Dup lab r s v_norm k_norm)
-- Stringifier
-- -----------
name :: Name -> String
name k = all !! fromIntegral (k+1) where
all :: [String]
all = [""] ++ concatMap (\str -> map (: str) ['a'..'z']) all
instance Show Term where
show (Var n) = name n
show (Let x t1 t2) = "! " ++ name x ++ " = " ++ show t1 ++ "; " ++ show t2
show Era = "*"
show (Sup l t1 t2)
| l == 0 = "{" ++ show t1 ++ "," ++ show t2 ++ "}"
| l == 1 = "<" ++ show t1 ++ "," ++ show t2 ++ ">"
| otherwise = "&" ++ show (fromIntegral l :: Int) ++ "{" ++ show t1 ++ "," ++ show t2 ++ "}"
show (Dup l x y t1 t2)
| l == 0 = "! {" ++ name x ++ "," ++ name y ++ "} = " ++ show t1 ++ "; " ++ show t2
| l == 1 = "! <" ++ name x ++ "," ++ name y ++ "> = " ++ show t1 ++ "; " ++ show t2
| otherwise = "! &" ++ show (fromIntegral l :: Int) ++ "{" ++ name x ++ "," ++ name y ++ "} = " ++ show t1 ++ "; " ++ show t2
show (Lam lab x t)
| lab == 0 = "λ" ++ name x ++ "." ++ show t
| lab == 1 = "Λ" ++ name x ++ "." ++ show t
| otherwise = "&" ++ show (fromIntegral lab :: Int) ++ " λ" ++ name x ++ "." ++ show t
show (App lab t1 t2)
| lab == 0 = "(" ++ show t1 ++ " " ++ show t2 ++ ")"
| lab == 1 = "[" ++ show t1 ++ " " ++ show t2 ++ "]"
| otherwise = "&" ++ show (fromIntegral lab :: Int) ++ " (" ++ show t1 ++ " " ++ show t2 ++ ")"
-- Parser
-- ------
type ParserST = Map.Map String Name
type LocalCtx = Map.Map String Name
type Parser a = ParsecT String ParserST IO a
whiteSpace :: Parser ()
whiteSpace = skipMany (space <|> comment) where
comment = do
try (string "//")
skipMany (noneOf "\n\r")
(newline <|> (eof >> return '\n'))
lexeme :: Parser a -> Parser a
lexeme p = p <* whiteSpace
symbol :: String -> Parser String
symbol s = lexeme (string s)
parseNatural :: Parser Integer
parseNatural = lexeme $ read <$> many1 digit
isGlobal :: String -> Bool
isGlobal name = take 1 name == "$"
getGlobalName :: String -> Parser Name
getGlobalName gname = do
globalMap <- getState
case Map.lookup gname globalMap of
Just n -> return n
Nothing -> do
n <- liftIO fresh
putState (Map.insert gname n globalMap)
return n
bindVar :: String -> LocalCtx -> Parser (Name, LocalCtx)
bindVar name ctx
| isGlobal name = do
n <- getGlobalName name
return (n, ctx)
| otherwise = do
n <- liftIO fresh
let ctx' = Map.insert name n ctx
return (n, ctx')
getVar :: String -> LocalCtx -> Parser Name
getVar name ctx
| isGlobal name = getGlobalName name
| otherwise = case Map.lookup name ctx of
Just n -> return n
Nothing -> fail $ "Unbound local variable: " ++ name
parseVarName :: Parser String
parseVarName = lexeme $ try (do
char '$'
name <- many1 (alphaNum <|> char '_')
return ("$" ++ name)
) <|> many1 (alphaNum <|> char '_')
-- Term parsers
parseTerm :: LocalCtx -> Parser Term
parseTerm ctx
= try (parseApp ctx)
<|> try (parseLet ctx)
<|> try (parseLam ctx)
<|> try (parseSup ctx)
<|> try (parseDup ctx)
<|> parseSimpleTerm ctx
parseSimpleTerm :: LocalCtx -> Parser Term
parseSimpleTerm ctx
= parseVar ctx
<|> parseEra
<|> between (symbol "(") (symbol ")") (parseTerm ctx)
parseVar :: LocalCtx -> Parser Term
parseVar ctx = do
name <- parseVarName
n <- getVar name ctx
return $ Var n
parseLam :: LocalCtx -> Parser Term
parseLam ctx = try (parseLamWithLabel ctx) <|> parseSimpleLam ctx <|> parseCapitalLam ctx
parseSimpleLam :: LocalCtx -> Parser Term
parseSimpleLam ctx = do
symbol "λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam 0 n body
parseCapitalLam :: LocalCtx -> Parser Term
parseCapitalLam ctx = do
symbol "Λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam 1 n body
parseLamWithLabel :: LocalCtx -> Parser Term
parseLamWithLabel ctx = do
symbol "&"
lab <- fromIntegral <$> parseNatural
symbol "λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam lab n body
parseApp :: LocalCtx -> Parser Term
parseApp ctx = try (parseAppWithLabel ctx) <|> parseSimpleApp ctx <|> parseSquareApp ctx
parseSimpleApp :: LocalCtx -> Parser Term
parseSimpleApp ctx = between (symbol "(") (symbol ")") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App 0 f a
parseSquareApp :: LocalCtx -> Parser Term
parseSquareApp ctx = between (symbol "[") (symbol "]") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App 1 f a
parseAppWithLabel :: LocalCtx -> Parser Term
parseAppWithLabel ctx = do
symbol "&"
lab <- fromIntegral <$> parseNatural
between (symbol "(") (symbol ")") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App lab f a
parseSup :: LocalCtx -> Parser Term
parseSup ctx = try (parseSupWithLabel ctx) <|> parseSimpleSup ctx <|> parseAngleSup ctx
parseSimpleSup :: LocalCtx -> Parser Term
parseSimpleSup ctx = between (symbol "{") (symbol "}") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup 0 a b
parseAngleSup :: LocalCtx -> Parser Term
parseAngleSup ctx = between (symbol "<") (symbol ">") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup 1 a b
parseSupWithLabel :: LocalCtx -> Parser Term
parseSupWithLabel ctx = do
symbol "&"
l <- fromIntegral <$> parseNatural
between (symbol "{") (symbol "}") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup l a b
parseDup :: LocalCtx -> Parser Term
parseDup ctx = try (parseDupWithLabel ctx) <|> parseSimpleDup ctx <|> parseAngleDup ctx
parseSimpleDup :: LocalCtx -> Parser Term
parseSimpleDup ctx = do
symbol "!"
(name1, name2) <- between (symbol "{") (symbol "}") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup 0 n1 n2 val body
parseAngleDup :: LocalCtx -> Parser Term
parseAngleDup ctx = do
symbol "!"
(name1, name2) <- between (symbol "<") (symbol ">") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup 1 n1 n2 val body
parseDupWithLabel :: LocalCtx -> Parser Term
parseDupWithLabel ctx = do
symbol "!"
symbol "&"
l <- fromIntegral <$> parseNatural
(name1, name2) <- between (symbol "{") (symbol "}") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup l n1 n2 val body
parseLet :: LocalCtx -> Parser Term
parseLet ctx = do
symbol "!"
name <- parseVarName
symbol "="
t1 <- parseTerm ctx
symbol ";"
(n, ctx') <- bindVar name ctx
t2 <- parseTerm ctx'
return $ Let n t1 t2
parseEra :: Parser Term
parseEra = do
symbol "*"
return Era
parseIC :: String -> IO (Either ParseError (Term, Map.Map String Name))
parseIC input = runParserT parser Map.empty "" input where
parser = do
whiteSpace
term <- parseTerm Map.empty
state <- getState
return (term, state)
doParseIC :: String -> IO Term
doParseIC input = do
result <- parseIC input
case result of
Left err -> error $ show err
Right (term, _) -> return term
-- Tests
-- -----
test_term :: String -> IO ()
test_term input = do
term <- doParseIC input
norm <- normal term
inters <- readIORef gINTERS
print norm
putStrLn $ "- WORK: " ++ show inters
test_ic :: IO ()
test_ic = do
-- (Λt.[t λx.x] λy.y)
test_term $ """
!F = λf.
!{f0,f1} = f;
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
!{f0,f1} = λx.(f0 (f1 x));
λx.(f0 (f1 x));
((F λnx.((nx λt0.λf0.f0) λt1.λf1.t1)) λT.λF.T)
"""
inters <- readIORef gINTERS
putStrLn $ "- WORK: " ++ show inters
main :: IO ()
main = test_ic
================================================
FILE: haskell/main_debug.hs
================================================
{- README.md -}
{-# LANGUAGE MultilineStrings #-}
-- This is like main.hs, but includes a step-by-step debugger.
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (chr, ord)
import Data.IORef
import Data.Word
import Debug.Trace
import System.IO.Unsafe (unsafePerformIO)
import Text.Parsec hiding (State)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map as Map
import qualified Text.Parsec as Parsec
import Data.Maybe (isJust)
type Name = Word64
data Term
= Var Name -- Name
| Let Name Term Term -- "! " Name " = " Term "; " Term
| Era -- "*"
| Sup Name Term Term -- "&" Name "{" Term "," Term "}"
| Dup Name Name Name Term Term -- "! &" Name "{" Name "," Name "}" "=" Term ";" Term
| Lam Name Name Term -- "&" Label "λ" Name "." Term
| App Name Term Term -- "&" Label "(" Term " " Term ")"
-- Globals
-- -------
{-# NOINLINE gSUBST #-}
gSUBST :: IORef (IntMap.IntMap Term)
gSUBST = unsafePerformIO $ newIORef IntMap.empty
{-# NOINLINE gFRESH #-}
gFRESH :: IORef Name
gFRESH = unsafePerformIO $ newIORef 0
{-# NOINLINE gINTERS #-}
gINTERS :: IORef Word64
gINTERS = unsafePerformIO $ newIORef 0
{-# NOINLINE gSTOP #-}
gSTOP :: IORef Bool
gSTOP = unsafePerformIO $ newIORef False
-- Helper functions for global substitution
set :: Name -> Term -> IO ()
set name term = do
subMap <- readIORef gSUBST
writeIORef gSUBST (IntMap.insert (fromIntegral name) term subMap)
get :: Name -> IO (Maybe Term)
get name = do
subMap <- readIORef gSUBST
let result = IntMap.lookup (fromIntegral name) subMap
when (isJust result) $ do
let newMap = IntMap.delete (fromIntegral name) subMap
writeIORef gSUBST newMap
return result
fresh :: IO Name
fresh = do
n <- readIORef gFRESH
writeIORef gFRESH (n + 1)
return n
incInters :: IO ()
incInters = do
n <- readIORef gINTERS
writeIORef gINTERS (n + 1)
markReduction :: IO ()
markReduction = writeIORef gSTOP True
hasReduced :: IO Bool
hasReduced = readIORef gSTOP
resetReduction :: IO ()
resetReduction = writeIORef gSTOP False
-- Function to display the substitution map
showSubst :: IO String
showSubst = do
subMap <- readIORef gSUBST
if IntMap.null subMap
then return ""
else do
let entries = IntMap.toList subMap
let showEntry (k, v) = name (fromIntegral k) ++ " <- " ++ show v
return $ unlines (map showEntry entries)
-- Evaluator
-- ---------
app_era :: Term -> Term -> IO Term
app_era Era _ = do
incInters
markReduction
return Era
app_era _ _ = error "app_era: expected Era as first argument"
app_lam :: Term -> Term -> Name -> IO Term
app_lam (Lam lam_lab nam bod) arg app_lab = do
incInters
markReduction
if lam_lab == app_lab then do
set nam arg
return bod
else do
y <- fresh
z <- fresh
f <- fresh
x <- fresh
v <- fresh
set nam (Lam app_lab y (Var z))
return $
(Let f bod
(Let x (App lam_lab arg (Var y))
(Let v (App app_lab (Var f) (Var x))
(Lam lam_lab z (Var v)))))
app_lam _ _ _ = error "app_lam: expected Lam as first argument"
app_sup :: Term -> Term -> Name -> IO Term
app_sup (Sup lab lft rgt) arg app_lab = do
incInters
markReduction
c0 <- fresh
c1 <- fresh
let a0 = App app_lab lft (Var c0)
let a1 = App app_lab rgt (Var c1)
return (Dup lab c0 c1 arg (Sup lab a0 a1))
app_sup _ _ _ = error "app_sup: expected Sup as first argument"
app_dup :: Term -> IO Term
app_dup (App app_lab f (Dup dup_lab x y val bod)) = do
incInters
markReduction
return (Dup dup_lab x y val (App app_lab f bod))
app_dup term = error "app_dup: expected App with Dup"
dup_era :: Term -> Term -> IO Term
dup_era (Dup lab r s _ k) Era = do
incInters
markReduction
set r Era
set s Era
return k
dup_era _ _ = error "dup_era: expected Dup and Era"
dup_lam :: Term -> Term -> IO Term
dup_lam (Dup lab r s _ k) (Lam lam_lab x f) = do
incInters
markReduction
x0 <- fresh
x1 <- fresh
f0 <- fresh
f1 <- fresh
set r (Lam lam_lab x0 (Var f0))
set s (Lam lam_lab x1 (Var f1))
set x (Sup lab (Var x0) (Var x1))
return (Dup lab f0 f1 f k)
dup_lam _ _ = error "dup_lam: expected Dup and Lam"
dup_sup :: Term -> Term -> IO Term
dup_sup (Dup dupLab x y _ k) (Sup supLab a b) = do
incInters
markReduction
if dupLab == supLab then do
set x a
set y b
return k
else do
a0 <- fresh
a1 <- fresh
b0 <- fresh
b1 <- fresh
set x (Sup supLab (Var a0) (Var b0))
set y (Sup supLab (Var a1) (Var b1))
return (Dup dupLab a0 a1 a (Dup dupLab b0 b1 b k))
dup_sup _ _ = error "dup_sup: expected Dup and Sup"
dup_dup :: Term -> Term -> IO Term
dup_dup (Dup labL x0 x1 _ t) (Dup labR y0 y1 y x) = do
incInters
markReduction
return (Dup labL x0 x1 x (Dup labL y0 y1 y t))
dup_dup _ _ = error "dup_dup: expected Dup with inner Dup"
whnf :: Term -> IO Term
whnf term = case term of
Var n -> do
sub <- get n
case sub of
Just s -> do
markReduction
whnf s
Nothing -> return (Var n)
Let x v b -> do
print "LET"
v' <- whnf v
didReduce <- hasReduced
if didReduce then
return (Let x v' b)
else do
set x v'
markReduction
whnf b
App app_lab f a -> do
f' <- whnf f
didReduce <- hasReduced
if didReduce then
return (App app_lab f' a)
else do
print "APP"
case f' of
Lam {} -> app_lam f' a app_lab
Sup {} -> app_sup f' a app_lab
Era -> app_era f' a
Dup {} -> app_dup (App app_lab f' a)
_ -> return (App app_lab f' a)
Dup dup_lab r s v k -> do
print "DUP"
v' <- whnf v
didReduce <- hasReduced
if didReduce then
return (Dup dup_lab r s v' k)
else
case v' of
Lam {} -> dup_lam (Dup dup_lab r s v' k) v'
Sup {} -> dup_sup (Dup dup_lab r s v' k) v'
Era -> dup_era (Dup dup_lab r s v' k) v'
Dup {} -> dup_dup (Dup dup_lab r s v' k) v'
_ -> return (Dup dup_lab r s v' k)
_ -> return term
-- FIXME: this is ugly, improve
step :: Term -> IO Term
step term = do
resetReduction
term' <- whnf term
didReduce <- hasReduced
if didReduce then
return term'
else do
resetReduction
case term' of
Lam lam_lab x b -> do
b' <- step b
didReduce <- hasReduced
if didReduce then do
markReduction
return (Lam lam_lab x b')
else
return term'
App app_lab f a -> do
f' <- step f
didReduce <- hasReduced
if didReduce then do
markReduction
return (App app_lab f' a)
else do
resetReduction
a' <- step a
didReduce <- hasReduced
if didReduce then do
markReduction
return (App app_lab f a')
else
return term'
Sup sup_lab a b -> do
a' <- step a
didReduce <- hasReduced
if didReduce then do
markReduction
return (Sup sup_lab a' b)
else do
resetReduction
b' <- step b
didReduce <- hasReduced
if didReduce then do
markReduction
return (Sup sup_lab a b')
else
return term'
Dup dup_lab r s v k -> do
v' <- step v
didReduce <- hasReduced
if didReduce then do
markReduction
return (Dup dup_lab r s v' k)
else do
resetReduction
k' <- step k
didReduce <- hasReduced
if didReduce then do
markReduction
return (Dup dup_lab r s v k')
else
return term'
_ -> return term'
normal :: Term -> IO Term
normal term = do
substStr <- showSubst
putStrLn $ substStr ++ show term
putStrLn $ replicate 40 '-'
term' <- step term
did_reduce <- hasReduced
if did_reduce then
normal term'
else
return term'
-- Stringifier
-- -----------
name :: Name -> String
name k = all !! fromIntegral (k+1) where
all :: [String]
all = [""] ++ concatMap (\str -> map (: str) ['a'..'z']) all
instance Show Term where
show (Var n) = name n
show (Let x t1 t2) = "! " ++ name x ++ " = " ++ show t1 ++ "; " ++ show t2
show Era = "*"
show (Sup l t1 t2)
| l == 0 = "{" ++ show t1 ++ "," ++ show t2 ++ "}"
| l == 1 = "<" ++ show t1 ++ "," ++ show t2 ++ ">"
| otherwise = "&" ++ show (fromIntegral l :: Int) ++ "{" ++ show t1 ++ "," ++ show t2 ++ "}"
show (Dup l x y t1 t2)
| l == 0 = "! {" ++ name x ++ "," ++ name y ++ "} = " ++ show t1 ++ "; " ++ show t2
| l == 1 = "! <" ++ name x ++ "," ++ name y ++ "> = " ++ show t1 ++ "; " ++ show t2
| otherwise = "! &" ++ show (fromIntegral l :: Int) ++ "{" ++ name x ++ "," ++ name y ++ "} = " ++ show t1 ++ "; " ++ show t2
show (Lam lab x t)
| lab == 0 = "λ" ++ name x ++ "." ++ show t
| lab == 1 = "Λ" ++ name x ++ "." ++ show t
| otherwise = "&" ++ show (fromIntegral lab :: Int) ++ " λ" ++ name x ++ "." ++ show t
show (App lab t1 t2)
| lab == 0 = "(" ++ show t1 ++ " " ++ show t2 ++ ")"
| lab == 1 = "[" ++ show t1 ++ " " ++ show t2 ++ "]"
| otherwise = "&" ++ show (fromIntegral lab :: Int) ++ " (" ++ show t1 ++ " " ++ show t2 ++ ")"
-- Parser
-- ------
type ParserST = Map.Map String Name
type LocalCtx = Map.Map String Name
type Parser a = ParsecT String ParserST IO a
whiteSpace :: Parser ()
whiteSpace = skipMany (space <|> comment) where
comment = do
try (string "//")
skipMany (noneOf "\n\r")
(newline <|> (eof >> return '\n'))
lexeme :: Parser a -> Parser a
lexeme p = p <* whiteSpace
symbol :: String -> Parser String
symbol s = lexeme (string s)
parseNatural :: Parser Integer
parseNatural = lexeme $ read <$> many1 digit
isGlobal :: String -> Bool
isGlobal name = take 1 name == "$"
getGlobalName :: String -> Parser Name
getGlobalName gname = do
globalMap <- getState
case Map.lookup gname globalMap of
Just n -> return n
Nothing -> do
n <- liftIO fresh
putState (Map.insert gname n globalMap)
return n
bindVar :: String -> LocalCtx -> Parser (Name, LocalCtx)
bindVar name ctx
| isGlobal name = do
n <- getGlobalName name
return (n, ctx)
| otherwise = do
n <- liftIO fresh
let ctx' = Map.insert name n ctx
return (n, ctx')
getVar :: String -> LocalCtx -> Parser Name
getVar name ctx
| isGlobal name = getGlobalName name
| otherwise = case Map.lookup name ctx of
Just n -> return n
Nothing -> fail $ "Unbound local variable: " ++ name
parseVarName :: Parser String
parseVarName = lexeme $ try (do
char '$'
name <- many1 (alphaNum <|> char '_')
return ("$" ++ name)
) <|> many1 (alphaNum <|> char '_')
-- Term parsers
parseTerm :: LocalCtx -> Parser Term
parseTerm ctx
= try (parseApp ctx)
<|> try (parseLet ctx)
<|> try (parseLam ctx)
<|> try (parseSup ctx)
<|> try (parseDup ctx)
<|> parseSimpleTerm ctx
parseSimpleTerm :: LocalCtx -> Parser Term
parseSimpleTerm ctx
= parseVar ctx
<|> parseEra
<|> between (symbol "(") (symbol ")") (parseTerm ctx)
parseVar :: LocalCtx -> Parser Term
parseVar ctx = do
name <- parseVarName
n <- getVar name ctx
return $ Var n
parseLam :: LocalCtx -> Parser Term
parseLam ctx = try (parseLamWithLabel ctx) <|> parseSimpleLam ctx <|> parseCapitalLam ctx
parseSimpleLam :: LocalCtx -> Parser Term
parseSimpleLam ctx = do
symbol "λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam 0 n body
parseCapitalLam :: LocalCtx -> Parser Term
parseCapitalLam ctx = do
symbol "Λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam 1 n body
parseLamWithLabel :: LocalCtx -> Parser Term
parseLamWithLabel ctx = do
symbol "&"
lab <- fromIntegral <$> parseNatural
symbol "λ"
name <- parseVarName
(n, ctx') <- bindVar name ctx
symbol "."
body <- parseTerm ctx'
return $ Lam lab n body
parseApp :: LocalCtx -> Parser Term
parseApp ctx = try (parseAppWithLabel ctx) <|> parseSimpleApp ctx <|> parseSquareApp ctx
parseSimpleApp :: LocalCtx -> Parser Term
parseSimpleApp ctx = between (symbol "(") (symbol ")") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App 0 f a
parseSquareApp :: LocalCtx -> Parser Term
parseSquareApp ctx = between (symbol "[") (symbol "]") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App 1 f a
parseAppWithLabel :: LocalCtx -> Parser Term
parseAppWithLabel ctx = do
symbol "&"
lab <- fromIntegral <$> parseNatural
between (symbol "(") (symbol ")") $ do
f <- parseTerm ctx
whiteSpace
a <- parseTerm ctx
return $ App lab f a
parseSup :: LocalCtx -> Parser Term
parseSup ctx = try (parseSupWithLabel ctx) <|> parseSimpleSup ctx <|> parseAngleSup ctx
parseSimpleSup :: LocalCtx -> Parser Term
parseSimpleSup ctx = between (symbol "{") (symbol "}") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup 0 a b
parseAngleSup :: LocalCtx -> Parser Term
parseAngleSup ctx = between (symbol "<") (symbol ">") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup 1 a b
parseSupWithLabel :: LocalCtx -> Parser Term
parseSupWithLabel ctx = do
symbol "&"
l <- fromIntegral <$> parseNatural
between (symbol "{") (symbol "}") $ do
a <- parseTerm ctx
symbol ","
b <- parseTerm ctx
return $ Sup l a b
parseDup :: LocalCtx -> Parser Term
parseDup ctx = try (parseDupWithLabel ctx) <|> parseSimpleDup ctx <|> parseAngleDup ctx
parseSimpleDup :: LocalCtx -> Parser Term
parseSimpleDup ctx = do
symbol "!"
(name1, name2) <- between (symbol "{") (symbol "}") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup 0 n1 n2 val body
parseAngleDup :: LocalCtx -> Parser Term
parseAngleDup ctx = do
symbol "!"
(name1, name2) <- between (symbol "<") (symbol ">") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup 1 n1 n2 val body
parseDupWithLabel :: LocalCtx -> Parser Term
parseDupWithLabel ctx = do
symbol "!"
symbol "&"
l <- fromIntegral <$> parseNatural
(name1, name2) <- between (symbol "{") (symbol "}") $ do
a <- parseVarName
symbol ","
b <- parseVarName
return (a, b)
symbol "="
val <- parseTerm ctx
symbol ";"
(n1, ctx') <- bindVar name1 ctx
(n2, ctx'') <- bindVar name2 ctx'
body <- parseTerm ctx''
return $ Dup l n1 n2 val body
parseLet :: LocalCtx -> Parser Term
parseLet ctx = do
symbol "!"
name <- parseVarName
symbol "="
t1 <- parseTerm ctx
symbol ";"
(n, ctx') <- bindVar name ctx
t2 <- parseTerm ctx'
return $ Let n t1 t2
parseEra :: Parser Term
parseEra = do
symbol "*"
return Era
parseIC :: String -> IO (Either ParseError (Term, Map.Map String Name))
parseIC input = runParserT parser Map.empty "" input where
parser = do
whiteSpace
term <- parseTerm Map.empty
state <- getState
return (term, state)
doParseIC :: String -> IO Term
doParseIC input = do
result <- parseIC input
case result of
Left err -> error $ show err
Right (term, _) -> return term
-- Tests
-- -----
test_term :: String -> IO ()
test_term input = do
term <- doParseIC input
_ <- normal term
inters <- readIORef gINTERS
putStrLn $ "- WORK: " ++ show inters
test_ic :: IO ()
test_ic = do
test_term $ """
!F = λf.
!{f0,f1} = f;
!{f0,f1} = λx.(f0 (f1 x));
λx.(f0 (f1 x));
((F λnx.((nx λt0.λf0.f0) λt1.λf1.t1)) λT.λF.T)
"""
inters <- readIORef gINTERS
putStrLn $ "- WORK: " ++ show inters
main :: IO ()
main = test_ic
================================================
FILE: haskell/modern_version.hs
================================================
-- Calculus of Interactions
-- ========================
-- CoI is a term rewrite system for the following grammar:
--
-- Term ::=
-- | Var ::= Name
-- | Dp0 ::= Name "₀"
-- | Dp1 ::= Name "₁"
-- | Era ::= "&{}"
-- | Sup ::= "&" Name "{" Term "," Term "}"
-- | Dup ::= "!" Name "&" Name "=" Term ";" Term
-- | Lam ::= "λ" Name "." Term
-- | App ::= "(" Term " " Term ")"
-- | Zer ::= "0"
-- | Suc ::= "1+"
-- | Ref ::= "@" Name
-- | Cal ::= Term "~>" Term
--
-- Where:
-- - Name ::= any sequence of base-64 chars in _ A-Z a-z 0-9 $
-- - [T] ::= any sequence of T separated by ","
--
-- In CoI:
-- - Variables are affine (they must occur at most once)
-- - Variables range globally (they can occur anywhere)
--
-- Terms are rewritten via the following interaction rules:
--
-- (λx.f a)
-- -------- app-lam
-- x ← a
-- f
--
-- (&L{f,g} a)
-- ----------------- app-sup
-- ! A &L = a
-- &L{(f A₀),(g A₁)}
--
-- ! X &L = &{}
-- ------------ dup-era
-- X₀ ← &{}
-- X₁ ← &{}
--
-- ! F &L = λx.f
-- ---------------- dup-lam
-- F₀ ← λ$x0.G₀
-- F₁ ← λ$x1.G₁
-- x ← &L{$x0,$x1}
-- ! G &L = f
--
-- ! X &L = &R{a,b}
-- ---------------- dup-sup
-- if L == R:
-- X₀ ← a
-- X₁ ← b
-- else:
-- ! A &L = a
-- ! B &L = b
-- X₀ ← &R{A₀,B₀}
-- X₁ ← &R{A₁,B₁}
--
-- ! X &L = 0
-- ---------- dup-zer
-- X₀ ← 0
-- X₁ ← 0
--
-- ! X &L = 1+n
-- ------------ dup-suc
-- ! N &L = n
-- X₀ ← 1+N₀
-- X₁ ← 1+N₁
--
-- ! X &L = Λ{0:z;1+:s}
-- -------------------- dup-swi
-- ! Z &L = z
-- ! S &L = s
-- X₀ ← Λ{0:Z₀;1+:S₀}
-- X₁ ← Λ{0:Z₁;1+:S₁}
--
-- @foo
-- ------------------ ref
-- foo ~> Book["foo"]
--
-- ((f ~> λx.g) a)
-- --------------- app-cal-lam
-- x ← a
-- (f x) ~> g
--
-- ((f ~> Λ{0:z;1+:s}) 0)
-- ---------------------- app-cal-swi-zer
-- (f 0) ~> z
--
-- ((f ~> Λ{0:z;1+:s}) 1+n)
-- ------------------------ app-cal-swi-suc
-- ((λp.(f 1+p) ~> s) n)
--
-- ((f ~> Λ{0:z;1+:s}) &L{a,b})
-- ---------------------------- app-cal-swi-sup
-- ! &L F = f
-- ! &L Z = z
-- ! &L N = s
-- &L{((F₀ ~> Λ{0:Z₀;1+:N₀}) a)
-- ,((F₁ ~> Λ{0:Z₁;1+:N₁}) b)}
--
-- ((f ~> &L{x,y}) a)
-- ------------------ app-cal-sup
-- ! F &L = f
-- ! A &L = a
-- &L{((F₀ ~> x) A₀))
-- ,((F₁ ~> y) A₁))}
--
-- ! &L X = f ~> g
-- --------------- dup-cal
-- ! F &L = f
-- ! G &L = g
-- X₀ ← F₀ ~> G₀
-- X₁ ← F₁ ~> G₁
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -O2 #-}
import Control.Monad (when, forM_)
import Data.Bits (shiftL)
import Data.Char (isDigit)
import Data.IORef
import Data.List (foldl', elemIndex)
import System.CPUTime
import Text.ParserCombinators.ReadP
import Text.Printf
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
debug :: Bool
debug = False
-- Types
-- =====
type Lab = Int
type Name = Int
data Term
= Nam !String
| Dry !Term !Term
| Var !Name
| Dp0 !Name
| Dp1 !Name
| Era
| Sup !Lab !Term !Term
| Dup !Name !Lab !Term !Term
| Lam !Name !Term
| App !Term !Term
| Zer
| Suc !Term
| Swi !Term !Term
| Ref !Name
| Cal !Term !Term
deriving (Eq)
data Kind
= VAR
| DP0
| DP1
deriving (Enum)
data Book = Book (M.Map Name Term)
data Env = Env
{ env_book :: !Book
, env_inters :: !(IORef Int)
, env_new_id :: !(IORef Int)
, env_sub_map :: !(IORef (IM.IntMap Term))
, env_dup_map :: !(IORef (IM.IntMap (Lab, Term)))
}
-- Showing
-- =======
instance Show Term where
show (Nam k) = (if debug then "." else "") ++ k
show (Dry f x) = (if debug then "." else "") ++ show_app f [x]
show (Var k) = int_to_name k
show (Dp0 k) = int_to_name k ++ "₀"
show (Dp1 k) = int_to_name k ++ "₁"
show Era = "&{}"
show (Sup l a b) = "&" ++ int_to_name l ++ "{" ++ show a ++ "," ++ show b ++ "}"
show (Dup k l v t) = "!" ++ int_to_name k ++ "&" ++ int_to_name l ++ "=" ++ show v ++ ";" ++ show t
show (Lam k f) = "λ" ++ int_to_name k ++ "." ++ show f
show (App f x) = show_app f [x]
show Zer = "0"
show (Suc p) = show_add 1 p
show (Swi z s) = "λ{0:" ++ show z ++ ";1+:" ++ show s ++ "}"
show (Ref k) = "@" ++ int_to_name k
show (Cal f g) = show f ++ "~>" ++ show g
show_add :: Int -> Term -> String
show_add n (Suc p) = show_add (n + 1) p
show_add n Zer = show n
show_add n term = show n ++ "+" ++ show term
show_app :: Term -> [Term] -> String
show_app (Dry f x) args = show_app f (x : args)
show_app (App f x) args = show_app f (x : args)
show_app f args = "(" ++ unwords (map show (f : args)) ++ ")"
instance Show Book where
show (Book m) = unlines [ "@" ++ int_to_name k ++ " = " ++ show ct | (k, ct) <- M.toList m ]
show_dup_map :: IM.IntMap (Lab, Term) -> String
show_dup_map m = unlines [ "! " ++ int_to_name k ++ " &" ++ int_to_name l ++ " = " ++ show v | (k, (l, v)) <- IM.toList m ]
show_sub_map :: IM.IntMap Term -> String
show_sub_map m = unlines [ int_to_name (k `div` 4) ++ suffix (k `mod` 4) ++ " ← " ++ show v | (k, v) <- IM.toList m ]
where suffix x = case x of { 0 -> "" ; 1 -> "₀" ; 2 -> "₁" ; _ -> "?" }
-- Name Encoding/Decoding
-- ======================
-- Base-64 encoding (for parsing user names/labels and printing)
-- Alphabet: _ (0), a-z (1-26), A-Z (27-52), 0-9 (53-62), $ (63).
alphabet :: String
alphabet = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$"
alphabet_first :: String
alphabet_first = filter (`notElem` "_0123456789") alphabet
name_to_int :: String -> Int
name_to_int = foldl' (\acc c -> (acc `shiftL` 6) + idx c) 0
where idx c = maybe (error "bad name char") id (elemIndex c alphabet)
int_to_name :: Int -> String
int_to_name 0 = "_"
int_to_name n = reverse (go n)
where go 0 = ""
go m = let (q,r) = m `divMod` 64 in alphabet !! r : go q
-- Parsing
-- =======
lexeme :: ReadP a -> ReadP a
lexeme p = skipSpaces *> p
parse_nam :: ReadP String
parse_nam = lexeme $ do
head <- satisfy (`elem` alphabet_first)
tail <- munch (`elem` alphabet)
return (head : tail)
parse_term :: ReadP Term
parse_term = parse_term_base
parse_term_base :: ReadP Term
parse_term_base = lexeme $ choice
[ parse_lam_or_swi
, parse_dup
, parse_app
, parse_sup
, parse_era
, parse_add
, parse_nat
, parse_ref
, parse_var
]
parse_app :: ReadP Term
parse_app = between (lexeme (char '(')) (lexeme (char ')')) $ do
ts <- many1 parse_term
let (t:rest) = ts
return (foldl' App t rest)
parse_lam_or_swi :: ReadP Term
parse_lam_or_swi = do
lexeme (choice [char 'λ', char '\\'])
parse_swi_body <++ parse_lam_body
parse_lam_body :: ReadP Term
parse_lam_body = do
k <- parse_nam
lexeme (char '.')
body <- parse_term
return (Lam (name_to_int k) body)
parse_swi_body :: ReadP Term
parse_swi_body = do
between (lexeme (char '{')) (lexeme (char '}')) $ do
lexeme (string "0:")
z <- parse_term
optional (lexeme (char ';'))
lexeme (string "1+:")
s <- parse_term
return (Swi z s)
parse_dup :: ReadP Term
parse_dup = do
lexeme (char '!')
k <- parse_nam
lexeme (char '&')
l <- parse_nam
lexeme (char '=')
v <- parse_term
optional (lexeme (char ';'))
t <- parse_term
return (Dup (name_to_int k) (name_to_int l) v t)
parse_sup :: ReadP Term
parse_sup = do
lexeme (char '&')
l <- parse_nam
between (lexeme (char '{')) (lexeme (char '}')) $ do
a <- parse_term
optional (lexeme (char ','))
b <- parse_term
return (Sup (name_to_int l) a b)
parse_era :: ReadP Term
parse_era = lexeme (string "&{}") >> return Era
parse_ref :: ReadP Term
parse_ref = do
lexeme (char '@')
k <- parse_nam
return (Ref (name_to_int k))
parse_add :: ReadP Term
parse_add = do
value <- parse_number
skipSpaces
_ <- char '+'
term <- parse_term_base
return (iterate Suc term !! value)
parse_nat :: ReadP Term
parse_nat = do
value <- parse_number
return (iterate Suc Zer !! value)
parse_number :: ReadP Int
parse_number = read <$> munch1 isDigit
parse_var :: ReadP Term
parse_var = do
k <- parse_nam
let kid = name_to_int k
choice
[ string "₀" >> return (Dp0 kid)
, string "₁" >> return (Dp1 kid)
, return (Var kid)
]
parse_func :: ReadP (Name, Term)
parse_func = do
lexeme (char '@')
k <- parse_nam
lexeme (char '=')
f <- parse_term
return (name_to_int k, f)
parse_book :: ReadP Book
parse_book = do
skipSpaces
funcs <- many parse_func
skipSpaces
eof
return $ Book (M.fromList funcs)
read_term :: String -> Term
read_term s = case readP_to_S (parse_term <* skipSpaces <* eof) s of
[(t, "")] -> t
_ -> error "bad-parse"
read_book :: String -> Book
read_book s = case readP_to_S parse_book s of
[(b, "")] -> b
_ -> error "bad-parse"
-- Environment
-- ===========
new_env :: Book -> IO Env
new_env bk = do
itr <- newIORef 0
ids <- newIORef 1
sub <- newIORef IM.empty
dm <- newIORef IM.empty
return $ Env bk itr ids sub dm
inc_inters :: Env -> IO ()
inc_inters e = do
!n <- readIORef (env_inters e)
writeIORef (env_inters e) (n + 1)
fresh :: Env -> IO Name
fresh e = do
!n <- readIORef (env_new_id e)
writeIORef (env_new_id e) (n + 1)
return ((n `shiftL` 6) + 63)
taker :: IORef (IM.IntMap a) -> Int -> IO (Maybe a)
taker ref k = do
!m <- readIORef ref
case IM.lookup k m of
Nothing -> do
return Nothing
Just v -> do
writeIORef ref (IM.delete k m)
return (Just v)
take_dup :: Env -> Name -> IO (Maybe (Lab, Term))
take_dup e k = taker (env_dup_map e) k
take_sub :: Kind -> Env -> Name -> IO (Maybe Term)
take_sub ki e k = taker (env_sub_map e) (k `shiftL` 2 + fromEnum ki)
subst :: Kind -> Env -> Name -> Term -> IO ()
subst s e k v = modifyIORef' (env_sub_map e) (IM.insert (k `shiftL` 2 + fromEnum s) v)
duply :: Env -> Name -> Lab -> Term -> IO ()
duply e k l v = modifyIORef' (env_dup_map e) (IM.insert k (l, v))
clone :: Env -> Lab -> Term -> IO (Term, Term)
clone e l v = do
k <- fresh e
duply e k l v
return $ (Dp0 k , Dp1 k)
clones :: Env -> Lab -> [Term] -> IO ([Term],[Term])
clones e l [] = return $ ([],[])
clones e l (x : xs) = do
(x0 , x1 ) <- clone e l x
(xs0, xs1) <- clones e l xs
return $ (x0 : xs0 , x1 : xs1)
-- WNF: Weak Normal Form
-- =====================
data Frame
= FApp Term
| FDp0 Name Lab
| FDp1 Name Lab
type Stack = [Frame]
wnf :: Env -> Stack -> Term -> IO Term
wnf = wnf_enter
-- WNF: Enter
-- ----------
wnf_enter :: Env -> Stack -> Term -> IO Term
wnf_enter e s (App f x) = do
when debug $ putStrLn $ ">> wnf_enter_app : " ++ show (App f x)
wnf_enter e (FApp x : s) f
wnf_enter e s (Var k) = do
when debug $ putStrLn $ ">> wnf_enter_var : " ++ show (Var k)
wnf_sub VAR e s k
wnf_enter e s (Dup k l v t) = do
when debug $ putStrLn $ ">> wnf_enter_dup : " ++ show (Dup k l v t)
duply e k l v
wnf_enter e s t
wnf_enter e s (Dp0 k) = do
when debug $ putStrLn $ ">> wnf_enter_dp0 : " ++ show (Dp0 k)
mlv <- take_dup e k
case mlv of
Just (l, v) -> wnf_enter e (FDp0 k l : s) v
Nothing -> wnf_sub DP0 e s k
wnf_enter e s (Dp1 k) = do
when debug $ putStrLn $ ">> wnf_enter_dp1 : " ++ show (Dp1 k)
mlv <- take_dup e k
case mlv of
Just (l, v) -> wnf_enter e (FDp1 k l : s) v
Nothing -> wnf_sub DP1 e s k
wnf_enter e s (Ref k) = do
when debug $ putStrLn $ ">> wnf_enter_ref : " ++ show (Ref k)
let (Book m) = env_book e
case M.lookup k m of
Just f -> do
inc_inters e
g <- alloc e f
when debug $ putStrLn $ ">> alloc : " ++ show g
wnf_enter e s (Cal (Nam ("@" ++ int_to_name k)) g)
Nothing -> error $ "UndefinedReference: " ++ int_to_name k
wnf_enter e s (Cal f g) = do
when debug $ putStrLn $ ">> wnf_enter_cal : " ++ show f ++ "~>" ++ show g
wnf_unwind e s (Cal f g)
wnf_enter e s f = do
when debug $ putStrLn $ ">> wnf_enter : " ++ show f
wnf_unwind e s f
-- WNF: Unwind
-- -----------
wnf_unwind :: Env -> Stack -> Term -> IO Term
wnf_unwind e [] v = return v
wnf_unwind e (x:s) v = do
when debug $ putStrLn $ ">> wnf_unwind : " ++ show v
case x of
FApp x -> case v of
Nam fk -> wnf_app_nam e s fk x
Dry ff fx -> wnf_app_dry e s ff fx x
Lam fk ff -> wnf_app_lam e s fk ff x
Sup fl fa fb -> wnf_app_sup e s fl fa fb x
Cal f g -> wnf_app_cal e s f g x
f -> wnf_unwind e s (App f x)
FDp0 k l -> case v of
Nam vk -> wnf_dpn_nam e s k l vk (Dp0 k)
Dry vf vx -> wnf_dpn_dry e s k l vf vx (Dp0 k)
Era -> wnf_dpn_era e s k l (Dp0 k)
Lam vk vf -> wnf_dpn_lam e s k l vk vf (Dp0 k)
Sup vl va vb -> wnf_dpn_sup e s k l vl va vb (Dp0 k)
Cal vf vg -> wnf_dpn_cal e s k l vf vg (Dp0 k)
Suc vp -> wnf_dpn_suc e s k l vp (Dp0 k)
Zer -> wnf_dpn_zer e s k l (Dp0 k)
Swi vz vs -> wnf_dpn_swi e s k l vz vs (Dp0 k)
val -> wnf_unwind e s (Dup k l val (Dp0 k))
FDp1 k l -> case v of
Era -> wnf_dpn_era e s k l (Dp1 k)
Dry vf vx -> wnf_dpn_dry e s k l vf vx (Dp1 k)
Lam vk vf -> wnf_dpn_lam e s k l vk vf (Dp1 k)
Sup vl va vb -> wnf_dpn_sup e s k l vl va vb (Dp1 k)
Cal vf vg -> wnf_dpn_cal e s k l vf vg (Dp1 k)
Suc vp -> wnf_dpn_suc e s k l vp (Dp1 k)
Zer -> wnf_dpn_zer e s k l (Dp1 k)
Swi vz vs -> wnf_dpn_swi e s k l vz vs (Dp1 k)
Nam n -> wnf_dpn_nam e s k l n (Dp1 k)
val -> wnf_unwind e s (Dup k l val (Dp1 k))
-- WNF: Interactions
-- -----------------
-- x | x₀ | x₁
wnf_sub :: Kind -> Env -> Stack -> Name -> IO Term
wnf_sub ki e s k = do
when debug $ putStrLn $ "## wnf_sub : " ++ int_to_name k
mt <- take_sub ki e k
case mt of
Just t -> wnf e s t
Nothing -> wnf_unwind e s $ case ki of
VAR -> Var k
DP0 -> Dp0 k
DP1 -> Dp1 k
-- .x
wnf_app_nam :: Env -> Stack -> String -> Term -> IO Term
wnf_app_nam e s fk v = do
when debug $ putStrLn $ "## wnf_app_nam : " ++ show (App (Nam fk) v)
wnf e s (Dry (Nam fk) v)
-- .(f x)
wnf_app_dry :: Env -> Stack -> Term -> Term -> Term -> IO Term
wnf_app_dry e s ff fx v = do
when debug $ putStrLn $ "## wnf_app_dry : " ++ show (App (Dry ff fx) v)
wnf e s (Dry (Dry ff fx) v)
-- (λx.f a)
wnf_app_lam :: Env -> Stack -> Name -> Term -> Term -> IO Term
wnf_app_lam e s fx ff v = do
when debug $ putStrLn $ "## wnf_app_lam : " ++ show (App (Lam fx ff) v)
inc_inters e
subst VAR e fx v
wnf e s ff
-- (&L{f,g} a)
wnf_app_sup :: Env -> Stack -> Lab -> Term -> Term -> Term -> IO Term
wnf_app_sup e s fL fa fb v = do
when debug $ putStrLn $ "## wnf_app_sup : " ++ show (App (Sup fL fa fb) v)
inc_inters e
(x0,x1) <- clone e fL v
wnf e s (Sup fL (App fa x0) (App fb x1))
-- ! X &L = &{}
wnf_dpn_era :: Env -> Stack -> Name -> Lab -> Term -> IO Term
wnf_dpn_era e s k _ t = do
when debug $ putStrLn $ "## wnf_dpn_era : " ++ show (Dup k (name_to_int "_") Era t)
inc_inters e
subst DP0 e k Era
subst DP1 e k Era
wnf e s t
-- ! F &L = λx.f
wnf_dpn_lam :: Env -> Stack -> Name -> Lab -> Name -> Term -> Term -> IO Term
wnf_dpn_lam e s k l vk vf t = do
when debug $ putStrLn $ "## wnf_dpn_lam : " ++ show (Dup k l (Lam vk vf) t)
inc_inters e
x0 <- fresh e
x1 <- fresh e
(g0,g1) <- clone e l vf
subst DP0 e k (Lam x0 g0)
subst DP1 e k (Lam x1 g1)
subst VAR e vk (Sup l (Var x0) (Var x1))
wnf e s t
-- ! X &L = &R{a,b}
wnf_dpn_sup :: Env -> Stack -> Name -> Lab -> Lab -> Term -> Term -> Term -> IO Term
wnf_dpn_sup e s k l vl va vb t
| l == vl = do
when debug $ putStrLn $ "## wnf_dpn_sup_same : " ++ show (Dup k l (Sup vl va vb) t)
inc_inters e
subst DP0 e k va
subst DP1 e k vb
wnf e s t
| otherwise = do
when debug $ putStrLn $ "## wnf_dpn_sup_diff : " ++ show (Dup k l (Sup vl va vb) t)
inc_inters e
(a0,a1) <- clone e l va
(b0,b1) <- clone e l vb
subst DP0 e k (Sup vl a0 b0)
subst DP1 e k (Sup vl a1 b1)
wnf e s t
-- ! X &L = 0
wnf_dpn_zer :: Env -> Stack -> Name -> Lab -> Term -> IO Term
wnf_dpn_zer e s k _ t = do
when debug $ putStrLn $ "## wnf_dpn_zer : " ++ show (Dup k (name_to_int "_") Zer t)
inc_inters e
subst DP0 e k Zer
subst DP1 e k Zer
wnf e s t
-- ! X &L = 1+n
wnf_dpn_suc :: Env -> Stack -> Name -> Lab -> Term -> Term -> IO Term
wnf_dpn_suc e s k l p t = do
when debug $ putStrLn $ "## wnf_dpn_suc : " ++ show (Dup k l (Suc p) t)
inc_inters e
(n0,n1) <- clone e l p
subst DP0 e k (Suc n0)
subst DP1 e k (Suc n1)
wnf e s t
-- ! X &L = Λ{0:z;1+:s}
wnf_dpn_swi :: Env -> Stack -> Name -> Lab -> Term -> Term -> Term -> IO Term
wnf_dpn_swi e s k l vz vs t = do
when debug $ putStrLn $ "## wnf_dpn_swi : " ++ show (Dup k l (Swi vz vs) t)
inc_inters e
(z0,z1) <- clone e l vz
(s0,s1) <- clone e l vs
subst DP0 e k (Swi z0 s0)
subst DP1 e k (Swi z1 s1)
wnf e s t
-- ! X &L = .x
wnf_dpn_nam :: Env -> Stack -> Name -> Lab -> String -> Term -> IO Term
wnf_dpn_nam e s k _ n t = do
when debug $ putStrLn $ "## wnf_dpn_nam : " ++ show (Dup k (name_to_int "_") (Nam n) t)
inc_inters e
subst DP0 e k (Nam n)
subst DP1 e k (Nam n)
wnf e s t
-- ! X &L = .(f x)
wnf_dpn_dry :: Env -> Stack -> Name -> Lab -> Term -> Term -> Term -> IO Term
wnf_dpn_dry e s k l vf vx t = do
when debug $ putStrLn $ "## wnf_dpn_dry : " ++ show (Dup k l (Dry vf vx) t)
inc_inters e
(f0,f1) <- clone e l vf
(x0,x1) <- clone e l vx
subst DP0 e k (Dry f0 x0)
subst DP1 e k (Dry f1 x1)
wnf e s t
-- ((f ~> g) a)
wnf_app_cal :: Env -> Stack -> Term -> Term -> Term -> IO Term
wnf_app_cal e s f g a = do
when debug $ putStrLn $ "## wnf_app_cal : " ++ show f ++ "~>" ++ show g ++ " " ++ show a
!g_wnf <- wnf e [] g
case g_wnf of
Lam fx ff -> wnf_app_cal_lam e s f fx ff a
Swi fz fs -> wnf_app_cal_swi e s f fz fs a
Sup fl ff fg -> wnf_app_cal_sup e s f fl ff fg a
_ -> wnf_unwind e s (App (Cal f g_wnf) a)
-- ((f ~> λx.g) a)
wnf_app_cal_lam :: Env -> Stack -> Term -> Name -> Term -> Term -> IO Term
wnf_app_cal_lam e s f x g a = do
when debug $ putStrLn $ "## wnf_app_cal_lam : " ++ show (Cal f (Lam x g)) ++ " " ++ show a
inc_inters e
subst VAR e x a
wnf_enter e s (Cal (App f (Var x)) g)
-- ((f ~> &L{x,y}) a)
wnf_app_cal_sup :: Env -> Stack -> Term -> Lab -> Term -> Term -> Term -> IO Term
wnf_app_cal_sup e s f l x y a = do
when debug $ putStrLn $ "## wnf_app_cal_sup : " ++ show (Cal f (Sup l x y)) ++ " " ++ show a
inc_inters e
(f0,f1) <- clone e l f
(a0,a1) <- clone e l a
let app0 = (App (Cal f0 x) a0)
let app1 = (App (Cal f1 y) a1)
wnf_enter e s (Sup l app0 app1)
-- ((f ~> Λ{0:z;1+:s}) a)
wnf_app_cal_swi :: Env -> Stack -> Term -> Term -> Term -> Term -> IO Term
wnf_app_cal_swi e s f z sc a = do
!a_wnf <- wnf e [] a
when debug $ putStrLn $ "## wnf_app_cal_swi : " ++ show (Cal f (Swi z sc)) ++ " " ++ show a ++ "→" ++ show a_wnf
case a_wnf of
Zer -> wnf_app_cal_swi_zer e s f z
Suc n -> wnf_app_cal_swi_suc e s f sc n
Sup l b c -> wnf_app_cal_swi_sup e s f z sc l b c
a -> wnf_unwind e s (App f a)
-- ((f ~> Λ{0:z;1+:s}) 0)
wnf_app_cal_swi_zer :: Env -> Stack -> Term -> Term -> IO Term
wnf_app_cal_swi_zer e s f z = do
when debug $ putStrLn $ "## wnf_app_cal_swi_zer : " ++ show (App (Cal f (Swi z (Nam "..."))) Zer)
inc_inters e
wnf_enter e s (Cal (App f Zer) z)
-- ((f ~> Λ{0:z;1+:s}) 1+n)
wnf_app_cal_swi_suc :: Env -> Stack -> Term -> Term -> Term -> IO Term
wnf_app_cal_swi_suc e s f sc n = do
when debug $ putStrLn $ "## wnf_app_cal_swi_suc : " ++ show (App (Cal f (Swi (Nam "...") sc)) (Suc n))
inc_inters e
p <- fresh e
wnf_enter e s (App (Cal (Lam p (App f (Suc (Var p)))) sc) n)
-- ((f ~> Λ{0:z;1+:s}) &L{a,b})
wnf_app_cal_swi_sup :: Env -> Stack -> Term -> Term -> Term -> Lab -> Term -> Term -> IO Term
wnf_app_cal_swi_sup e s f z sc l a b = do
when debug $ putStrLn $ "## wnf_app_cal_swi_sup : " ++ show (App (Cal f (Swi z sc)) (Sup l a b))
inc_inters e
(f0,f1) <- clone e l f
(z0,z1) <- clone e l z
(s0,s1) <- clone e l sc
let app0 = App (Cal f0 (Swi z0 s0)) a
let app1 = App (Cal f1 (Swi z1 s1)) b
wnf_enter e s (Sup l app0 app1)
-- ! &L X = f ~> g
wnf_dpn_cal :: Env -> Stack -> Name -> Lab -> Term -> Term -> Term -> IO Term
wnf_dpn_cal e s k l f g t = do
when debug $ putStrLn $ "## wnf_dpn_cal : " ++ show (Dup k l (Cal f g) t)
inc_inters e
(f0,f1) <- clone e l f
(g0,g1) <- clone e l g
subst DP0 e k (Cal f0 g0)
subst DP1 e k (Cal f1 g1)
wnf_enter e s t
-- Allocation
-- ==========
-- Allocates a closed term, replacing all bound names with fresh ones.
alloc :: Env -> Term -> IO Term
alloc e term = go IM.empty term where
go :: IM.IntMap Name -> Term -> IO Term
go m (Var k) = return $ Var (IM.findWithDefault k k m)
go m (Dp0 k) = return $ Dp0 (IM.findWithDefault k k m)
go m (Dp1 k) = return $ Dp1 (IM.findWithDefault k k m)
go _ Era = return Era
go m (Sup l a b) = Sup l <$> go m a <*> go m b
go m (App f x) = App <$> go m f <*> go m x
go _ Zer = return Zer
go m (Suc n) = Suc <$> go m n
go m (Swi z s) = Swi <$> go m z <*> go m s
go _ (Ref k) = return $ Ref k
go m (Cal f g) = Cal <$> go m f <*> go m g
go m (Dup k l v t) = do
k' <- fresh e
v' <- go m v
t' <- go (IM.insert k k' m) t
return $ Dup k' l v' t'
go m (Lam k f) = do
k' <- fresh e
f' <- go (IM.insert k k' m) f
return $ Lam k' f'
-- Normalization
-- =============
snf :: Env -> Int -> Term -> IO Term
snf e d x = do
when debug $ putStrLn $ "!! nf " ++ show x
!x' <- wnf e [] x
when debug $ putStrLn $ "!! →→" ++ show x'
case x' of
Nam k -> do
return $ Nam k
Dry f x -> do
f' <- snf e d f
x' <- snf e d x
return $ Dry f' x'
Var k -> do
return $ Var k
Dp0 k -> do
return $ Dp0 k
Dp1 k -> do
return $ Dp1 k
Era -> do
return Era
App f x -> do
f' <- snf e d f
x' <- snf e d x
return $ App f' x'
Sup l a b -> do
a' <- snf e d a
b' <- snf e d b
return $ Sup l a' b'
Lam k f -> do
subst VAR e k (Nam (int_to_name d))
f' <- snf e (d + 1) f
return $ Lam d f'
Dup k l v t -> do
subst DP0 e k (Nam (int_to_name d ++ "₀"))
subst DP1 e k (Nam (int_to_name d ++ "₁"))
v' <- snf e d v
t' <- snf e d t
return $ Dup d l v' t'
Zer -> do
return Zer
Suc p -> do
p' <- snf e d p
return $ Suc p'
Swi z s -> do
z' <- snf e d z
s' <- snf e d s
return $ Swi z' s'
Ref k -> do
return $ Ref k
Cal f g -> do
g' <- snf e d g
return g'
-- Collapsing
-- ==========
col :: Env -> Term -> IO Term
col e x = do
!x <- wnf e [] x
case x of
(Sup l a b) -> do
a' <- col e a
b' <- col e b
return $ Sup l a' b'
(Suc p) -> do
pV <- fresh e
p' <- col e p
inj e (Lam pV (Suc (Var pV))) [p']
(Lam k f) -> do
fV <- fresh e
f' <- col e f
inj e (Lam fV (Lam k (Var fV))) [f']
(App f x) -> do
fV <- fresh e
xV <- fresh e
f' <- col e f
x' <- col e x
inj e (Lam fV (Lam xV (App (Var fV) (Var xV)))) [f',x']
(Swi z s) -> do
zV <- fresh e
sV <- fresh e
z' <- col e z
s' <- col e s
inj e (Lam zV (Lam sV (Swi (Var zV) (Var sV)))) [z',s']
(Cal f g) -> do
col e g
x -> do
return $ x
inj :: Env -> Term -> [Term] -> IO Term
inj e f (x : xs) = do
!x' <- wnf e [] x
case x' of
(Sup l a b) -> do
(f0 , f1 ) <- clone e l f
(xs0 , xs1) <- clones e l xs
a' <- inj e f0 (a : xs0)
b' <- inj e f1 (b : xs1)
return $ Sup l a' b'
x' -> do
inj e (App f x') xs
inj e f [] = do
return $ f
-- Main
-- ====
run :: String -> String -> IO ()
run book_src term_src = do
let book = read_book book_src
!env <- new_env book
let term = read_term term_src
!ini <- getCPUTime
!val <- alloc env term
!val <- col env val
!val <- snf env 1 val
-- !nf1 <- nf env 1 nf0
!end <- getCPUTime
!itr <- readIORef (env_inters env)
let diff = fromIntegral (end - ini) / (10^12)
let rate = fromIntegral itr / diff
putStrLn $ show val
putStrLn $ "- Itrs: " ++ show itr ++ " interactions"
printf "- Time: %.3f seconds\n" (diff :: Double)
printf "- Perf: %.2f M interactions/s\n" (rate / 1000000 :: Double)
f :: Int -> String
f n = "λf." ++ dups ++ final where
dups = concat [dup i | i <- [0..n-1]]
dup 0 = "!F00&A=f;"
dup i = "!F" ++ pad i ++ "&A=λx" ++ pad (i-1) ++ ".(F" ++ pad (i-1) ++ "₀ (F" ++ pad (i-1) ++ "₁ x" ++ pad (i-1) ++ "));"
final = "λx" ++ pad (n-1) ++ ".(F" ++ pad (n-1) ++ "₀ (F" ++ pad (n-1) ++ "₁ x" ++ pad (n-1) ++ "))"
pad x = if x < 10 then "0" ++ show x else show x
tests :: [(String,String)]
tests =
[ ("(@not 0)", "1")
, ("(@not 1+0)", "0")
, ("!F&L=@id;!G&L=F₀;λx.(G₁ x)", "λa.a")
, ("(@and 0 0)", "0")
, ("(@and &L{0,1+0} 1+0)", "&L{0,1}")
, ("(@and &L{1+0,0} 1+0)", "&L{1,0}")
, ("(@and 1+0 &L{0,1+0})", "&L{0,1}")
, ("(@and 1+0 &L{1+0,0})", "&L{1,0}")
, ("λx.(@and 0 x)", "λa.(@and 0 a)")
, ("λx.(@and x 0)", "λa.(@and a 0)")
, ("(@sum 1+1+1+0)", "6")
, ("λx.(@sum 1+1+1+x)", "λa.3+(@add a 2+(@add a 1+(@add a (@sum a))))")
, ("(@foo 0)", "&L{0,0}")
, ("(@foo 1+1+1+0)", "&L{3,2}")
, ("λx.(@dbl 1+1+x)", "λa.4+(@dbl a)")
, ("("++f 2++" λX.(X λT0.λF0.F0 λT1.λF1.T1) λT2.λF2.T2)", "λa.λb.a")
, ("1+&L{0,1}", "&L{1,2}")
, ("1+&A{&B{0,1},&C{2,3}}", "&A{&B{1,2},&C{3,4}}")
, ("λa.!A&L=a;&L{A₀,A₁}", "&L{λa.a,λa.a}")
, ("λa.λb.!A&L=a;!B&L=b;&L{λx.(x A₀ B₀),λx.(x A₁ B₁)}", "&L{λa.λb.λc.(c a b),λa.λb.λc.(c a b)}")
, ("λt.(t &A{1,2} 3)", "&A{λa.(a 1 3),λa.(a 2 3)}")
, ("λt.(t 1 &B{3,4})", "&B{λa.(a 1 3),λa.(a 1 4)}")
, ("λt.(t &A{1,2} &A{3,4})", "&A{λa.(a 1 3),λa.(a 2 4)}")
, ("λt.(t &A{1,2} &B{3,4})", "&A{&B{λa.(a 1 3),λa.(a 1 4)},&B{λa.(a 2 3),λa.(a 2 4)}}")
, ("@gen", "&A{&B{λa.a,λa.1+a},&C{&D{λ{0:0;1+:λa.(@gen a)},&E{λ{0:0;1+:λa.1+(@gen a)},λ{0:0;1+:λa.2+(@gen a)}}},&D{λ{0:1;1+:λa.(@gen a)},&E{λ{0:1;1+:λa.1+(@gen a)},λ{0:1;1+:λa.2+(@gen a)}}}}}")
, ("λx.(@gen 2+x)", "&A{&B{λa.2+a,λa.3+a},&D{λa.(@gen a),&E{λa.2+(@gen a),λa.4+(@gen a)}}}")
, ("(@gen 2)", "&A{&B{2,3},&D{&C{0,1},&E{&C{2,3},&C{4,5}}}}")
]
book :: String
book = unlines
[ "@id = λa.a"
, "@not = λ{0:1+0;1+:λp.0}"
, "@dbl = λ{0:0;1+:λp.1+1+(@dbl p)}"
, "@and = λ{0:λ{0:0;1+:λp.0};1+:λp.λ{0:0;1+:λp.1+0}}"
, "@add = λ{0:λb.b;1+:λa.λb.1+(@add a b)}"
, "@sum = λ{0:0;1+:λp.!P&S=p;1+(@add P₀ (@sum P₁))}"
, "@foo = &L{λx.x,λ{0:0;1+:λp.p}}"
, "@gen = !F&A=@gen &A{λx.!X&B=x;&B{X₀,1+X₁},λ{0:&C{0,1};1+:λp.!G&D=F₁;!P&D=p;&D{(G₀ P₀),!H&E=G₁;!Q&E=P₁;1+&E{(H₀ Q₀),1+(H₁ Q₁)}}}}"
]
test :: IO ()
test = forM_ tests $ \ (src, exp) -> do
env <- new_env (read_book book)
det <- col env $ read_term src
det <- show <$> snf env 1 det
if det == exp then do
putStrLn $ "[PASS] " ++ src ++ " → " ++ det
else do
putStrLn $ "[FAIL] " ++ src
putStrLn $ " - expected: " ++ exp
putStrLn $ " - detected: " ++ det
main :: IO ()
main = test
================================================
FILE: src/collapse.c
================================================
//./../IC.md//
//./ic.h//
//./collapse.h//
// This is a WIP
#include "ic.h"
#include "collapse.h"
#include "show.h"
// -----------------------------------------------------------------------------
// Collapse Interactions
// -----------------------------------------------------------------------------
// λx.*
// ------ ERA-LAM
// x <- *
// *
static inline Term ic_era_lam(IC* ic, Term lam, Term era) {
ic->interactions++;
Val lam_loc = TERM_VAL(lam);
// Set substitution for x to an erasure
ic->heap[lam_loc] = ic_make_sub(ic_make_era());
// Return an erasure
return ic_make_era();
}
// (f *)
// ----- ERA-APP
// *
static inline Term ic_era_app(IC* ic, Term app, Term era) {
ic->interactions++;
// Return an erasure
return ic_make_era();
}
// λx.&L{f0,f1}
// ----------------- SUP-LAM
// x <- &L{x0,x1}
// &L{λx0.f0,λx1.f1}
static inline Term ic_sup_lam(IC* ic, Term lam, Term sup) {
ic->interactions++;
Val lam_loc = TERM_VAL(lam);
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term f0 = ic->heap[sup_loc + 0];
Term f1 = ic->heap[sup_loc + 1];
// Allocate two new LAM nodes
Val lam0_loc = ic_alloc(ic, 1);
Val lam1_loc = ic_alloc(ic, 1);
ic->heap[lam0_loc + 0] = f0;
ic->heap[lam1_loc + 0] = f1;
// Create variables x0 and x1 pointing to lam0 and lam1
Term x0 = ic_make_term(VAR, 0, lam0_loc);
Term x1 = ic_make_term(VAR, 0, lam1_loc);
// Create the new SUP &L{x0,x1}
Val new_sup_loc = ic_alloc(ic, 2);
ic->heap[new_sup_loc + 0] = x0;
ic->heap[new_sup_loc + 1] = x1;
Term new_sup = ic_make_sup(sup_lab, new_sup_loc);
// Set substitution for x (original LAM variable)
ic->heap[lam_loc] = ic_make_sub(new_sup);
// Create the result SUP &L{lam0, lam1}
Term lam0_term = ic_make_term(LAM, 0, lam0_loc);
Term lam1_term = ic_make_term(LAM, 0, lam1_loc);
Val result_sup_loc = ic_alloc(ic, 2);
ic->heap[result_sup_loc + 0] = lam0_term;
ic->heap[result_sup_loc + 1] = lam1_term;
return ic_make_sup(sup_lab, result_sup_loc);
}
// (f &L{x0,x1})
// ------------------- SUP-APP
// !&L{f0,f1} = f
// &L{(f0 x0),(f1 x1)}
static inline Term ic_sup_app(IC* ic, Term app, Term sup) {
ic->interactions++;
Val app_loc = TERM_VAL(app);
Lab sup_lab = TERM_LAB(sup);
Term fun = ic->heap[app_loc + 0];
Val sup_loc = TERM_VAL(sup);
Term lft = ic->heap[sup_loc + 0];
Term rgt = ic->heap[sup_loc + 1];
// Allocate DUP node for fun
Val dup_loc = ic_alloc(ic, 1);
ic->heap[dup_loc] = fun;
// Create f0 and f1
Term f0 = ic_make_co0(sup_lab, dup_loc);
Term f1 = ic_make_co1(sup_lab, dup_loc);
// Create app0 = (f0 lft)
Val app0_loc = ic_alloc(ic, 2);
ic->heap[app0_loc + 0] = f0;
ic->heap[app0_loc + 1] = lft;
Term app0 = ic_make_term(APP, 0, app0_loc);
// Create app1 = (f1 rgt)
Val app1_loc = ic_alloc(ic, 2);
ic->heap[app1_loc + 0] = f1;
ic->heap[app1_loc + 1] = rgt;
Term app1 = ic_make_term(APP, 0, app1_loc);
// Create result SUP &L{app0, app1}
Val result_sup_loc = ic_alloc(ic, 2);
ic->heap[result_sup_loc + 0] = app0;
ic->heap[result_sup_loc + 1] = app1;
return ic_make_sup(sup_lab, result_sup_loc);
}
// &R{&L{x0,x1},y}
// ----------------------- SUP-SUP-X (if R>L)
// !&R{y0,y1} = y;
// &L{&R{x0,x1},&R{y0,y1}}
static inline Term ic_sup_sup_x(IC* ic, Term outer_sup, Term inner_sup) {
ic->interactions++;
Val outer_sup_loc = TERM_VAL(outer_sup);
Lab outer_lab = TERM_LAB(outer_sup);
Val inner_sup_loc = TERM_VAL(inner_sup);
Lab inner_lab = TERM_LAB(inner_sup);
Term x0 = ic->heap[inner_sup_loc + 0];
Term x1 = ic->heap[inner_sup_loc + 1];
Term y = ic->heap[outer_sup_loc + 1];
// Allocate DUP node for y with label outer_lab
Val dup_loc = ic_alloc(ic, 1);
ic->heap[dup_loc] = y;
// Create y0 and y1 with label outer_lab
Term y0 = ic_make_co0(outer_lab, dup_loc);
Term y1 = ic_make_co1(outer_lab, dup_loc);
// Create sup0 = &outer_lab{x0, y0}
Val sup0_loc = ic_alloc(ic, 2);
ic->heap[sup0_loc + 0] = x0;
ic->heap[sup0_loc + 1] = y0;
Term sup0 = ic_make_sup(outer_lab, sup0_loc);
// Create sup1 = &outer_lab{x1, y1}
Val sup1_loc = ic_alloc(ic, 2);
ic->heap[sup1_loc + 0] = x1;
ic->heap[sup1_loc + 1] = y1;
Term sup1 = ic_make_sup(outer_lab, sup1_loc);
// Create result SUP &inner_lab{sup0, sup1}
Val result_sup_loc = ic_alloc(ic, 2);
ic->heap[result_sup_loc + 0] = sup0;
ic->heap[result_sup_loc + 1] = sup1;
return ic_make_sup(inner_lab, result_sup_loc);
}
// &R{x,&L{y0,y1}}
// ----------------------- SUP-SUP-Y (if R>L)
// !&R{x0,x1} = x;
// &L{&R{x0,x1},&R{y0,y1}}
static inline Term ic_sup_sup_y(IC* ic, Term outer_sup, Term inner_sup) {
ic->interactions++;
Val outer_sup_loc = TERM_VAL(outer_sup);
Lab outer_lab = TERM_LAB(outer_sup);
Val inner_sup_loc = TERM_VAL(inner_sup);
Lab inner_lab = TERM_LAB(inner_sup);
Term x = ic->heap[outer_sup_loc + 0];
Term y0 = ic->heap[inner_sup_loc + 0];
Term y1 = ic->heap[inner_sup_loc + 1];
// Allocate DUP node for x with label outer_lab
Val dup_loc = ic_alloc(ic, 1);
ic->heap[dup_loc] = x;
// Create x0 and x1 with label outer_lab
Term x0 = ic_make_co0(outer_lab, dup_loc);
Term x1 = ic_make_co1(outer_lab, dup_loc);
// Create sup0 = &outer_lab{x0, y0}
Val sup0_loc = ic_alloc(ic, 2);
ic->heap[sup0_loc + 0] = x0;
ic->heap[sup0_loc + 1] = y0;
Term sup0 = ic_make_sup(outer_lab, sup0_loc);
// Create sup1 = &outer_lab{x1, y1}
Val sup1_loc = ic_alloc(ic, 2);
ic->heap[sup1_loc + 0] = x1;
ic->heap[sup1_loc + 1] = y1;
Term sup1 = ic_make_sup(outer_lab, sup1_loc);
// Create result SUP &inner_lab{sup0, sup1}
Val result_sup_loc = ic_alloc(ic, 2);
ic->heap[result_sup_loc + 0] = sup0;
ic->heap[result_sup_loc + 1] = sup1;
return ic_make_sup(inner_lab, result_sup_loc);
}
// !&L{x0,x1} = x; K
// ----------------- DUP-VAR
// x0 <- x
// x1 <- x
// K
static inline Term ic_dup_var(IC* ic, Term dup, Term var) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
ic->heap[dup_loc] = ic_make_sub(var);
return var;
}
// !&L{a0,a1} = (f x); K
// --------------------- DUP-APP
// a0 <- (f0 x0)
// a1 <- (f1 x1)
// !&L{f0,f1} = f;
// !&L{x0,x1} = x;
// K
static inline Term ic_dup_app(IC* ic, Term dup, Term app) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
Lab lab = TERM_LAB(dup);
TermTag tag = TERM_TAG(dup);
bool is_co0 = IS_DP0(tag);
Val app_loc = TERM_VAL(app);
Term fun = ic->heap[app_loc + 0];
Term arg = ic->heap[app_loc + 1];
// Allocate DUP nodes for fun and arg
Val dup_fun_loc = ic_alloc(ic, 1);
ic->heap[dup_fun_loc] = fun;
Val dup_arg_loc = ic_alloc(ic, 1);
ic->heap[dup_arg_loc] = arg;
// Create DP0 and DP1 for fun
Term f0 = ic_make_co0(lab, dup_fun_loc);
Term f1 = ic_make_co1(lab, dup_fun_loc);
// Create DP0 and DP1 for arg
Term x0 = ic_make_co0(lab, dup_arg_loc);
Term x1 = ic_make_co1(lab, dup_arg_loc);
// Create app0 = (f0 x0)
Val app0_loc = ic_alloc(ic, 2);
ic->heap[app0_loc + 0] = f0;
ic->heap[app0_loc + 1] = x0;
Term app0 = ic_make_term(APP, 0, app0_loc);
// Create app1 = (f1 x1)
Val app1_loc = ic_alloc(ic, 2);
ic->heap[app1_loc + 0] = f1;
ic->heap[app1_loc + 1] = x1;
Term app1 = ic_make_term(APP, 0, app1_loc);
// Set substitution and return
if (is_co0) {
ic->heap[dup_loc] = ic_make_sub(app1);
return app0;
} else {
ic->heap[dup_loc] = ic_make_sub(app0);
return app1;
}
}
// ~N{0:&L{z0,z1};+:s;}
// --------------------------------- SUP-SWI-Z
// !&L{N0,N1} = N;
// !&L{S0,S1} = S;
// &L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}
static inline Term ic_sup_swi_z(IC* ic, Term swi, Term sup) {
ic->interactions++;
Val swi_loc = TERM_VAL(swi);
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term num = ic->heap[swi_loc + 0];
Term z0 = ic->heap[sup_loc + 0];
Term z1 = ic->heap[sup_loc + 1];
Term s = ic->heap[swi_loc + 2];
// Create duplications for num and s
Val dup_n_loc = ic_alloc(ic, 1);
Val dup_s_loc = ic_alloc(ic, 1);
ic->heap[dup_n_loc] = num;
ic->heap[dup_s_loc] = s;
Term n0 = ic_make_co0(sup_lab, dup_n_loc);
Term n1 = ic_make_co1(sup_lab, dup_n_loc);
Term s0 = ic_make_co0(sup_lab, dup_s_loc);
Term s1 = ic_make_co1(sup_lab, dup_s_loc);
// Create switch nodes for each branch
Val swi0_loc = ic_alloc(ic, 3);
ic->heap[swi0_loc + 0] = n0;
ic->heap[swi0_loc + 1] = z0;
ic->heap[swi0_loc + 2] = s0;
Val swi1_loc = ic_alloc(ic, 3);
ic->heap[swi1_loc + 0] = n1;
ic->heap[swi1_loc + 1] = z1;
ic->heap[swi1_loc + 2] = s1;
// Create the resulting superposition
Val res_loc = ic_alloc(ic, 2);
ic->heap[res_loc + 0] = ic_make_term(SWI, 0, swi0_loc);
ic->heap[res_loc + 1] = ic_make_term(SWI, 0, swi1_loc);
return ic_make_sup(sup_lab, res_loc);
}
// ~N{0:z;+:&0{s0,s1};}
// --------------------------------- SUP-SWI-S
// !&L{N0,N1} = N;
// !&L{Z0,Z1} = Z;
// &L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}
static inline Term ic_sup_swi_s(IC* ic, Term swi, Term sup) {
ic->interactions++;
Val swi_loc = TERM_VAL(swi);
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term num = ic->heap[swi_loc + 0];
Term z = ic->heap[swi_loc + 1];
Term s0 = ic->heap[sup_loc + 0];
Term s1 = ic->heap[sup_loc + 1];
// Create duplications for num and z
Val dup_n_loc = ic_alloc(ic, 1);
Val dup_z_loc = ic_alloc(ic, 1);
ic->heap[dup_n_loc] = num;
ic->heap[dup_z_loc] = z;
Term n0 = ic_make_co0(sup_lab, dup_n_loc);
Term n1 = ic_make_co1(sup_lab, dup_n_loc);
Term z0 = ic_make_co0(sup_lab, dup_z_loc);
Term z1 = ic_make_co1(sup_lab, dup_z_loc);
// Create switch nodes for each branch
Val swi0_loc = ic_alloc(ic, 3);
ic->heap[swi0_loc + 0] = n0;
ic->heap[swi0_loc + 1] = z0;
ic->heap[swi0_loc + 2] = s0;
Val swi1_loc = ic_alloc(ic, 3);
ic->heap[swi1_loc + 0] = n1;
ic->heap[swi1_loc + 1] = z1;
ic->heap[swi1_loc + 2] = s1;
// Create the resulting superposition
Val res_loc = ic_alloc(ic, 2);
ic->heap[res_loc + 0] = ic_make_term(SWI, 0, swi0_loc);
ic->heap[res_loc + 1] = ic_make_term(SWI, 0, swi1_loc);
return ic_make_sup(sup_lab, res_loc);
}
// -----------------------------------------------------------------------------
// Collapser
// -----------------------------------------------------------------------------
Term ic_collapse_sups(IC* ic, Term term) {
TermTag tag;
Lab lab;
Val loc;
term = ic_whnf(ic, term);
tag = TERM_TAG(term);
lab = TERM_LAB(term);
loc = TERM_VAL(term);
if (tag == LAM) {
ic->heap[loc+0] = ic_collapse_sups(ic, ic->heap[loc+0]);
} else if (tag == APP) {
ic->heap[loc+0] = ic_collapse_sups(ic, ic->heap[loc+0]);
ic->heap[loc+1] = ic_collapse_sups(ic, ic->heap[loc+1]);
} else if (IS_SUP(tag)) {
ic->heap[loc+0] = ic_collapse_sups(ic, ic->heap[loc+0]);
ic->heap[loc+1] = ic_collapse_sups(ic, ic->heap[loc+1]);
}
term = ic_whnf(ic, term);
tag = TERM_TAG(term);
lab = TERM_LAB(term);
loc = TERM_VAL(term);
if (tag == LAM) {
Term bod_col = ic->heap[loc+0];
if (IS_SUP(TERM_TAG(bod_col))) {
//printf(">> SUP-LAM\n");
return ic_collapse_sups(ic, ic_sup_lam(ic, term, bod_col));
} else if (ic_is_era(bod_col)) {
//printf(">> ERA-LAM\n");
return ic_collapse_sups(ic, ic_era_lam(ic, term, bod_col));
}
} else if (tag == APP) {
Term fun_col = ic->heap[loc+0];
Term arg_col = ic->heap[loc+1];
if (IS_SUP(TERM_TAG(arg_col))) {
//printf(">> SUP-APP\n");
return ic_collapse_sups(ic, ic_sup_app(ic, term, arg_col));
} else if (ic_is_era(arg_col)) {
//printf(">> ERA-APP\n");
return ic_collapse_sups(ic, ic_era_app(ic, term, arg_col));
}
} else if (IS_SUP(tag)) {
Term lft_col = ic->heap[loc+0];
Term rgt_col = ic->heap[loc+1];
if (IS_SUP(TERM_TAG(lft_col)) && lab > TERM_LAB(lft_col)) {
//printf(">> SUP-SUP-X\n");
return ic_collapse_sups(ic, ic_sup_sup_x(ic, term, lft_col));
} else if (IS_SUP(TERM_TAG(rgt_col)) && lab > TERM_LAB(rgt_col)) {
//printf(">> SUP-SUP-Y\n");
return ic_collapse_sups(ic, ic_sup_sup_y(ic, term, rgt_col));
}
} else if (tag == SWI) {
Term num = ic->heap[loc+0];
Term ifz = ic->heap[loc+1];
Term ifs = ic->heap[loc+2];
if (IS_SUP(TERM_TAG(ifz))) {
//printf(">> SUP-SWI-Z\n");
return ic_collapse_sups(ic, ic_sup_swi_z(ic, term, ifz));
} else if (IS_SUP(TERM_TAG(ifs))) {
//printf(">> SUP-SWI-S\n");
return ic_collapse_sups(ic, ic_sup_swi_s(ic, term, ifs));
}
}
return term;
}
Term ic_collapse_dups(IC* ic, Term term) {
term = ic_whnf(ic, term);
TermTag tag = TERM_TAG(term);
Val loc = TERM_VAL(term);
if (IS_DUP(tag)) {
// Get the value this collapser points to
Term val = ic_collapse_dups(ic, ic->heap[loc]);
TermTag val_tag = TERM_TAG(val);
if (val_tag == VAR) {
//printf(">> DUP-VAR\n");
return ic_collapse_dups(ic, ic_dup_var(ic, term, val));
} else if (val_tag == APP) {
//printf(">> DUP-APP\n");
return ic_collapse_dups(ic, ic_dup_app(ic, term, val));
} else if (ic_is_era(val)) {
//printf(">> DUP-ERA\n");
return ic_collapse_dups(ic, ic_dup_era(ic, term, val));
} else {
return term;
}
} else if (tag == LAM) {
ic->heap[loc+0] = ic_collapse_dups(ic, ic->heap[loc+0]);
return term;
} else if (tag == APP) {
ic->heap[loc+0] = ic_collapse_dups(ic, ic->heap[loc+0]);
ic->heap[loc+1] = ic_collapse_dups(ic, ic->heap[loc+1]);
return term;
} else if (IS_SUP(tag)) {
ic->heap[loc+0] = ic_collapse_dups(ic, ic->heap[loc+0]);
ic->heap[loc+1] = ic_collapse_dups(ic, ic->heap[loc+1]);
return term;
} else if (tag == SUC) {
ic->heap[loc] = ic_collapse_dups(ic, ic->heap[loc]);
return term;
} else if (tag == SWI) {
ic->heap[loc+0] = ic_collapse_dups(ic, ic->heap[loc+0]);
ic->heap[loc+1] = ic_collapse_dups(ic, ic->heap[loc+1]);
ic->heap[loc+2] = ic_collapse_dups(ic, ic->heap[loc+2]);
return term;
} else if (ic_is_era(term) || tag == NUM) {
// ERA and NUM have no children, so just return them
return term;
} else {
return term;
}
}
================================================
FILE: src/collapse.h
================================================
//./collapse.c//
#ifndef IC_COLLAPSE_H
#define IC_COLLAPSE_H
#include "ic.h"
static inline Term ic_era_lam(IC* ic, Term lam, Term era);
static inline Term ic_era_app(IC* ic, Term app, Term era);
static inline Term ic_sup_lam(IC* ic, Term lam, Term sup);
static inline Term ic_sup_app(IC* ic, Term app, Term sup);
static inline Term ic_sup_sup_x(IC* ic, Term outer_sup, Term inner_sup);
static inline Term ic_sup_sup_y(IC* ic, Term outer_sup, Term inner_sup);
static inline Term ic_dup_var(IC* ic, Term dup, Term var);
static inline Term ic_dup_app(IC* ic, Term dup, Term app);
// Numeric collapse operations
static inline Term ic_sup_swi_z(IC* ic, Term swi, Term sup);
static inline Term ic_sup_swi_s(IC* ic, Term swi, Term sup);
Term ic_collapse_sups(IC* ic, Term term);
Term ic_collapse_dups(IC* ic, Term term);
#endif // IC_COLLAPSE_H
================================================
FILE: src/ic.c
================================================
#include "ic.h"
// -----------------------------------------------------------------------------
// Memory Management Functions
// -----------------------------------------------------------------------------
// Create a new IC context with the specified heap and stack sizes.
// @param heap_size Number of terms in the heap
// @param stack_size Number of terms in the stack
// @return A new IC context or NULL if allocation failed
inline IC* ic_new(Val heap_size, Val stack_size) {
IC* ic = (IC*)malloc(sizeof(IC));
if (!ic) return NULL;
// Initialize structure
ic->heap_size = heap_size;
ic->stack_size = stack_size;
ic->heap_pos = 0;
ic->interactions = 0;
ic->stack_pos = 0;
// Allocate heap and stack
ic->heap = (Term*)calloc(heap_size, sizeof(Term));
ic->stack = (Term*)malloc(stack_size * sizeof(Term));
if (!ic->heap || !ic->stack) {
ic_free(ic);
return NULL;
}
return ic;
}
// Create a new IC context with default heap and stack sizes.
// @return A new IC context or NULL if allocation failed
inline IC* ic_default_new() {
return ic_new(IC_DEFAULT_HEAP_SIZE, IC_DEFAULT_STACK_SIZE);
}
// Free all resources associated with an IC context.
// @param ic The IC context to free
inline void ic_free(IC* ic) {
if (!ic) return;
if (ic->heap) free(ic->heap);
if (ic->stack) free(ic->stack);
free(ic);
}
// Allocate n consecutive terms in memory.
// @param ic The IC context
// @param n Number of terms to allocate
// @return Location in the heap
// Does NOT bound check. We'll add a less frequent checker elsewhere.
inline Val ic_alloc(IC* ic, Val n) {
Val ptr = ic->heap_pos;
ic->heap_pos += n;
return ptr;
}
// -----------------------------------------------------------------------------
// Term Manipulation Functions
// -----------------------------------------------------------------------------
// Create a term with the given tag and value.
// @param tag Term type tag (includes label for SUP, CX, CY)
// @param val Value/pointer into the heap
// @return The constructed term
inline Term ic_make_term(TermTag tag, Lab lab, Val val) {
return MAKE_TERM(false, tag, lab, val);
}
// Create a substitution term.
// @param term The term to convert to a substitution
// @return The term with its substitution bit set
inline Term ic_make_sub(Term term) {
return term | TERM_SUB_MASK;
}
// Remove the substitution bit from a term.
// @param term The term to clear the substitution bit from
// @return The term with its substitution bit cleared
inline Term ic_clear_sub(Term term) {
return term & ~TERM_SUB_MASK;
}
// Helper to create a term with the appropriate superposition tag for a label
// @param lab Label value (0-3)
// @param val Value/pointer into the heap
// @return The constructed superposition term
inline Term ic_make_sup(Lab lab, Val val) {
return ic_make_term(SUP_BASE_TAG, lab, val);
}
// Helper to create a DP0 term with the appropriate tag for a label
// @param lab Label value (0-3)
// @param val Value/pointer into the heap
// @return The constructed DP0 term
inline Term ic_make_co0(Lab lab, Val val) {
return ic_make_term(DP0_BASE_TAG, lab, val);
}
// Helper to create a DP1 term with the appropriate tag for a label
// @param lab Label value (0-3)
// @param val Value/pointer into the heap
// @return The constructed DP1 term
inline Term ic_make_co1(Lab lab, Val val) {
return ic_make_term(DP1_BASE_TAG, lab, val);
}
// Helper to create an erasure term
// @return An erasure term (ERA tag with no value)
inline Term ic_make_era() {
return ic_make_term(ERA, 0, 0);
}
// Helper to create a number term
// @param val The numeric value
// @return A number term
inline Term ic_make_num(Val val) {
return ic_make_term(NUM, 0, val);
}
// Helper to create a successor term
// @param val Pointer to the successor node
// @return A successor term
inline Term ic_make_suc(Val val) {
return ic_make_term(SUC, 0, val);
}
// Helper to create a switch term
// @param val Pointer to the switch node
// @return A switch term
inline Term ic_make_swi(Val val) {
return ic_make_term(SWI, 0, val);
}
// Check if a term is an erasure
// @param term The term to check
// @return True if the term is an erasure, false otherwise
inline bool ic_is_era(Term term) {
return TERM_TAG(term) == ERA;
}
// Allocs a Lam node
inline Val ic_lam(IC* ic, Term bod) {
Val lam_loc = ic_alloc(ic, 1);
ic->heap[lam_loc + 0] = bod;
return lam_loc;
}
// Allocs an App node
inline Val ic_app(IC* ic, Term fun, Term arg) {
Val app_loc = ic_alloc(ic, 2);
ic->heap[app_loc + 0] = fun;
ic->heap[app_loc + 1] = arg;
return app_loc;
}
// Allocs a Sup node
inline Val ic_sup(IC* ic, Term lft, Term rgt) {
Val sup_loc = ic_alloc(ic, 2);
ic->heap[sup_loc + 0] = lft;
ic->heap[sup_loc + 1] = rgt;
return sup_loc;
}
// Allocs a Dup node
inline Val ic_dup(IC* ic, Term val) {
Val dup_loc = ic_alloc(ic, 1);
ic->heap[dup_loc] = val;
return dup_loc;
}
// Allocs a Suc node
inline Val ic_suc(IC* ic, Term num) {
Val suc_loc = ic_alloc(ic, 1);
ic->heap[suc_loc] = num;
return suc_loc;
}
// Allocs a Swi node
inline Val ic_swi(IC* ic, Term num, Term ifz, Term ifs) {
Val swi_loc = ic_alloc(ic, 3);
ic->heap[swi_loc + 0] = num;
ic->heap[swi_loc + 1] = ifz;
ic->heap[swi_loc + 2] = ifs;
return swi_loc;
}
// -----------------------------------------------------------------------------
// Core Interactions
// -----------------------------------------------------------------------------
//(λx.f a)
//-------- APP-LAM
//x <- a
//f
inline Term ic_app_lam(IC* ic, Term app, Term lam) {
ic->interactions++;
Val app_loc = TERM_VAL(app);
Val lam_loc = TERM_VAL(lam);
Term arg = ic->heap[app_loc + 1];
Term bod = ic->heap[lam_loc + 0];
// Create substitution for the lambda variable
ic->heap[lam_loc] = ic_make_sub(arg);
return bod;
}
//(* a)
//----- APP-ERA
//*
inline Term ic_app_era(IC* ic, Term app, Term era) {
ic->interactions++;
return era; // Return the erasure term
}
//(&L{a,b} c)
//----------------- APP-SUP
//! &L{c0,c1} = c;
//&L{(a c0),(b c1)}
inline Term ic_app_sup(IC* ic, Term app, Term sup) {
ic->interactions++;
Val app_loc = TERM_VAL(app);
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term arg = ic->heap[app_loc + 1];
Term lft = ic->heap[sup_loc + 0];
Term rgt = ic->heap[sup_loc + 1];
// Allocate only what's necessary
Val dup_loc = ic_alloc(ic, 1);
Val app1_loc = ic_alloc(ic, 2);
// Store the arg in the duplication location
ic->heap[dup_loc] = arg;
// Create DP0 and DP1 terms
Term x0 = ic_make_co0(sup_lab, dup_loc);
Term x1 = ic_make_co1(sup_lab, dup_loc);
// Reuse sup_loc for app0
ic->heap[sup_loc + 1] = x0; // lft is already in heap[sup_loc + 0]
// Set up app1
ic->heap[app1_loc + 0] = rgt;
ic->heap[app1_loc + 1] = x1;
// Reuse app_loc for the result superposition
ic->heap[app_loc + 0] = ic_make_term(APP, 0, sup_loc);
ic->heap[app_loc + 1] = ic_make_term(APP, 0, app1_loc);
// Use same superposition tag as input
return ic_make_sup(sup_lab, app_loc);
}
//! &L{r,s} = *;
//K
//-------------- DUP-ERA
//r <- *
//s <- *
//K
inline Term ic_dup_era(IC* ic, Term dup, Term era) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
TermTag dup_tag = TERM_TAG(dup);
bool is_co0 = IS_DP0(dup_tag);
// Create erasure term for substitution
Term era_term = ic_make_era();
// Set substitution
ic->heap[dup_loc] = ic_make_sub(era_term);
// Return an erasure
return era_term;
}
//! &L{r,s} = λx.f;
//K
//----------------- DUP-LAM
//r <- λx0.f0
//s <- λx1.f1
//x <- &L{x0,x1}
//! &L{f0,f1} = f;
//K
inline Term ic_dup_lam(IC* ic, Term dup, Term lam) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
Val lam_loc = TERM_VAL(lam);
Lab dup_lab = TERM_LAB(dup);
TermTag dup_tag = TERM_TAG(dup);
bool is_co0 = IS_DP0(dup_tag);
Term bod = ic->heap[lam_loc + 0];
// Batch allocate memory for efficiency
Val alloc_start = ic_alloc(ic, 5);
Val lam0_loc = alloc_start;
Val lam1_loc = alloc_start + 1;
Val sup_loc = alloc_start + 2; // 2 locations
Val dup_new_loc = alloc_start + 4;
// Set up the superposition
ic->heap[sup_loc + 0] = ic_make_term(VAR, 0, lam0_loc);
ic->heap[sup_loc + 1] = ic_make_term(VAR, 0, lam1_loc);
// Replace lambda's variable with the superposition
ic->heap[lam_loc] = ic_make_sub(ic_make_sup(dup_lab, sup_loc));
// Set up the new duplication
ic->heap[dup_new_loc] = bod;
// Set up new lambda bodies
ic->heap[lam0_loc] = ic_make_co0(dup_lab, dup_new_loc);
ic->heap[lam1_loc] = ic_make_co1(dup_lab, dup_new_loc);
// Create and return the appropriate lambda
if (is_co0) {
ic->heap[dup_loc] = ic_make_sub(ic_make_term(LAM, 0, lam1_loc));
return ic_make_term(LAM, 0, lam0_loc);
} else {
ic->heap[dup_loc] = ic_make_sub(ic_make_term(LAM, 0, lam0_loc));
return ic_make_term(LAM, 0, lam1_loc);
}
}
//! &L{x,y} = &L{a,b};
//K
//-------------------- DUP-SUP (if equal labels)
//x <- a
//y <- b
//K
//! &L{x,y} = &R{a,b};
//K
//-------------------- DUP-SUP (if different labels)
//x <- &R{a0,b0}
//y <- &R{a1,b1}
//! &L{a0,a1} = a
//! &L{b0,b1} = b
//K
inline Term ic_dup_sup(IC* ic, Term dup, Term sup) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
Val sup_loc = TERM_VAL(sup);
Lab dup_lab = TERM_LAB(dup);
Lab sup_lab = TERM_LAB(sup);
TermTag dup_tag = TERM_TAG(dup);
bool is_co0 = IS_DP0(dup_tag);
Term lft = ic->heap[sup_loc + 0];
Term rgt = ic->heap[sup_loc + 1];
// Fast path for matching labels (common case)
if (dup_lab == sup_lab) {
// Labels match: simple substitution
if (is_co0) {
ic->heap[dup_loc] = ic_make_sub(rgt);
return lft;
} else {
ic->heap[dup_loc] = ic_make_sub(lft);
return rgt;
}
} else {
// Labels don't match: create nested duplications
Val sup_start = ic_alloc(ic, 4); // 2 sups with 2 terms each
Val sup0_loc = sup_start;
Val sup1_loc = sup_start + 2;
// Use existing locations as duplication locations
Val dup_lft_loc = sup_loc + 0;
Val dup_rgt_loc = sup_loc + 1;
// Set up the first superposition (for DP0)
ic->heap[sup0_loc + 0] = ic_make_co0(dup_lab, dup_lft_loc);
ic->heap[sup0_loc + 1] = ic_make_co0(dup_lab, dup_rgt_loc);
// Set up the second superposition (for DP1)
ic->heap[sup1_loc + 0] = ic_make_co1(dup_lab, dup_lft_loc);
ic->heap[sup1_loc + 1] = ic_make_co1(dup_lab, dup_rgt_loc);
// Set up original duplications to point to lft and rgt
ic->heap[dup_lft_loc] = lft;
ic->heap[dup_rgt_loc] = rgt;
if (is_co0) {
ic->heap[dup_loc] = ic_make_sub(ic_make_sup(sup_lab, sup1_loc));
return ic_make_sup(sup_lab, sup0_loc);
} else {
ic->heap[dup_loc] = ic_make_sub(ic_make_sup(sup_lab, sup0_loc));
return ic_make_sup(sup_lab, sup1_loc);
}
}
}
// -----------------------------------------------------------------------------
// Numeric Interactions
// -----------------------------------------------------------------------------
//+N
//--- SUC-NUM
//N+1
inline Term ic_suc_num(IC* ic, Term suc, Term num) {
ic->interactions++;
uint32_t num_val = TERM_VAL(num);
return ic_make_num(num_val + 1);
}
//+*
//-- SUC-ERA
//*
inline Term ic_suc_era(IC* ic, Term suc, Term era) {
ic->interactions++;
return era; // Erasure propagates
}
//+&L{x,y}
//--------- SUC-SUP
//&L{+x,+y}
inline Term ic_suc_sup(IC* ic, Term suc, Term sup) {
ic->interactions++;
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term lft = ic->heap[sup_loc + 0];
Term rgt = ic->heap[sup_loc + 1];
// Create SUC nodes for each branch
Val suc0_loc = ic_suc(ic, lft);
Val suc1_loc = ic_suc(ic, rgt);
// Create the resulting superposition of SUCs
Val res_loc = ic_alloc(ic, 2);
ic->heap[res_loc + 0] = ic_make_suc(suc0_loc);
ic->heap[res_loc + 1] = ic_make_suc(suc1_loc);
return ic_make_sup(sup_lab, res_loc);
}
//?N{0:z;+:s;}
//------------ SWI-NUM (if N==0)
//z
inline Term ic_swi_num(IC* ic, Term swi, Term num) {
ic->interactions++;
Val swi_loc = TERM_VAL(swi);
Val num_val = TERM_VAL(num);
Term ifz = ic->heap[swi_loc + 1];
Term ifs = ic->heap[swi_loc + 2];
if (num_val == 0) {
// If the number is 0, return the zero branch
return ifz;
} else {
// Otherwise, apply the successor branch to N-1
Val app_loc = ic_alloc(ic, 2);
ic->heap[app_loc + 0] = ifs;
ic->heap[app_loc + 1] = ic_make_num(num_val - 1);
return ic_make_term(APP, 0, app_loc);
}
}
//?*{0:z;+:s;}
//------------ SWI-ERA
//*
inline Term ic_swi_era(IC* ic, Term swi, Term era) {
ic->interactions++;
return era; // Erasure propagates
}
//?&L{x,y}{0:z;+:s;}
//--------------------------------- SWI-SUP
//!&L{z0,z1} = z;
//!&L{s0,s1} = s;
//&L{?x{0:z0;+:s0;},?y{0:z1;+:s1;}}
inline Term ic_swi_sup(IC* ic, Term swi, Term sup) {
ic->interactions++;
Val swi_loc = TERM_VAL(swi);
Val sup_loc = TERM_VAL(sup);
Lab sup_lab = TERM_LAB(sup);
Term lft = ic->heap[sup_loc + 0];
Term rgt = ic->heap[sup_loc + 1];
Term ifz = ic->heap[swi_loc + 1];
Term ifs = ic->heap[swi_loc + 2];
// Create duplications for ifz and ifs branches
Val dup_z_loc = ic_alloc(ic, 1);
Val dup_s_loc = ic_alloc(ic, 1);
ic->heap[dup_z_loc] = ifz;
ic->heap[dup_s_loc] = ifs;
Term z0 = ic_make_co0(sup_lab, dup_z_loc);
Term z1 = ic_make_co1(sup_lab, dup_z_loc);
Term s0 = ic_make_co0(sup_lab, dup_s_loc);
Term s1 = ic_make_co1(sup_lab, dup_s_loc);
// Create switch nodes for each branch
Val swi0_loc = ic_swi(ic, lft, z0, s0);
Val swi1_loc = ic_swi(ic, rgt, z1, s1);
// Create the resulting superposition
Val res_loc = ic_alloc(ic, 2);
ic->heap[res_loc + 0] = ic_make_term(SWI, 0, swi0_loc);
ic->heap[res_loc + 1] = ic_make_term(SWI, 0, swi1_loc);
return ic_make_sup(sup_lab, res_loc);
}
//! &L{x,y} = N;
//K
//-------------- DUP-NUM
//x <- N
//y <- N
//K
inline Term ic_dup_num(IC* ic, Term dup, Term num) {
ic->interactions++;
Val dup_loc = TERM_VAL(dup);
Val num_val = TERM_VAL(num);
TermTag dup_tag = TERM_TAG(dup);
bool is_co0 = IS_DP0(dup_tag);
// Numbers are duplicated by simply substituting both variables with the same number
ic->heap[dup_loc] = ic_make_sub(num); // Set substitution for the other variable
return num; // Return the number
}
// -----------------------------------------------------------------------------
// Term Normalization
// -----------------------------------------------------------------------------
// Reduce a term to weak head normal form (WHNF).
//
// @param ic The IC context
// @param term The term to reduce
// @return The term in WHNF
inline Term ic_whnf(IC* ic, Term term) {
Val stop = ic->stack_pos;
Term next = term;
Term* heap = ic->heap;
Term* stack = ic->stack;
Val stack_pos = stop;
TermTag tag;
Val val_loc;
Term val;
Term prev;
TermTag ptag;
while (1) {
tag = TERM_TAG(next);
// On variables: substitute
// On eliminators: move to field
if (tag == VAR) {
val_loc = TERM_VAL(next);
val = heap[val_loc];
if (TERM_SUB(val)) {
next = ic_clear_sub(val);
continue;
}
} else if (IS_DUP(tag)) {
val_loc = TERM_VAL(next);
val = heap[val_loc];
if (TERM_SUB(val)) {
next = ic_clear_sub(val);
continue;
} else {
stack[stack_pos++] = next;
next = val;
continue;
}
} else if (tag == APP) {
val_loc = TERM_VAL(next);
stack[stack_pos++] = next;
next = heap[val_loc]; // Reduce the function part
continue;
} else if (tag == SUC) {
val_loc = TERM_VAL(next);
stack[stack_pos++] = next;
next = heap[val_loc]; // Reduce the inner term
continue;
} else if (tag == SWI) {
val_loc = TERM_VAL(next);
stack[stack_pos++] = next;
next = heap[val_loc]; // Reduce the number term
continue;
}
// Empty stack: term is in WHNF
if (stack_pos == stop) {
ic->stack_pos = stack_pos;
return next;
}
// Interaction Dispatcher
prev = stack[--stack_pos];
ptag = TERM_TAG(prev);
if (ptag == APP) {
if (tag == LAM) {
next = ic_app_lam(ic, prev, next);
continue;
} else if (IS_SUP(tag)) {
next = ic_app_sup(ic, prev, next);
continue;
} else if (tag == ERA) {
next = ic_app_era(ic, prev, next);
continue;
}
} else if (IS_DUP(ptag)) {
if (tag == LAM) {
next = ic_dup_lam(ic, prev, next);
continue;
} else if (IS_SUP(tag)) {
next = ic_dup_sup(ic, prev, next);
continue;
} else if (tag == ERA) {
next = ic_dup_era(ic, prev, next);
continue;
} else if (tag == NUM) {
next = ic_dup_num(ic, prev, next);
continue;
}
} else if (ptag == SUC) {
if (tag == NUM) {
next = ic_suc_num(ic, prev, next);
continue;
} else if (IS_SUP(tag)) {
next = ic_suc_sup(ic, prev, next);
continue;
} else if (tag == ERA) {
next = ic_suc_era(ic, prev, next);
continue;
}
} else if (ptag == SWI) {
if (tag == NUM) {
next = ic_swi_num(ic, prev, next);
continue;
} else if (IS_SUP(tag)) {
next = ic_swi_sup(ic, prev, next);
continue;
} else if (tag == ERA) {
next = ic_swi_era(ic, prev, next);
continue;
}
}
// No interaction: push term back to stack
stack[stack_pos++] = prev;
// Check if we're done
if (stack_pos == stop) {
ic->stack_pos = stack_pos;
return next;
}
// Update parent chain
while (stack_pos > stop) {
prev = stack[--stack_pos];
ptag = TERM_TAG(prev);
val_loc = TERM_VAL(prev);
if (ptag == APP || ptag == SWI || IS_DUP(ptag)) {
heap[val_loc] = next;
}
next = prev;
}
ic->stack_pos = stack_pos;
return next;
}
}
// Recursive implementation of normal form reduction
inline Term ic_normal(IC* ic, Term term) {
term = ic_whnf(ic, term);
TermTag tag = TERM_TAG(term);
Val loc = TERM_VAL(term);
if (ic_is_era(term) || tag == NUM) {
// ERA and NUM have no children, so just return them
return term;
} else if (tag == LAM) {
ic->heap[loc] = ic_normal(ic, ic->heap[loc]);
return term;
} else if (tag == APP) {
ic->heap[loc+0] = ic_normal(ic, ic->heap[loc]);
ic->heap[loc+1] = ic_normal(ic, ic->heap[loc+1]);
return term;
} else if (IS_SUP(tag)) {
ic->heap[loc+0] = ic_normal(ic, ic->heap[loc]);
ic->heap[loc+1] = ic_normal(ic, ic->heap[loc+1]);
return term;
} else if (tag == SUC) {
ic->heap[loc] = ic_normal(ic, ic->heap[loc]);
return term;
} else if (tag == SWI) {
ic->heap[loc+0] = ic_normal(ic, ic->heap[loc]);
ic->heap[loc+1] = ic_normal(ic, ic->heap[loc+1]);
ic->heap[loc+2] = ic_normal(ic, ic->heap[loc+2]);
return term;
} else {
return term;
}
}
================================================
FILE: src/ic.h
================================================
#ifndef IC_H
#define IC_H
// -----------------------------------------------------------------------------
// Interaction Calculus (IC) - Core header-only implementation
//
// This file contains the full implementation of the Interaction Calculus:
// - Term representation and bit manipulation
// - Memory management
// - Core interactions (app_lam, app_sup, dup_lam, dup_sup)
// - Weak Head Normal Form (WHNF) reduction
// - Full Normal Form reduction
// -----------------------------------------------------------------------------
#include <stdint.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
// Default heap and stack sizes
#ifdef IC_64BIT
#define IC_DEFAULT_HEAP_SIZE (1ULL << 30) // 1G terms
#define IC_DEFAULT_STACK_SIZE (1ULL << 28) // 256M terms
#else
#define IC_DEFAULT_HEAP_SIZE (1UL << 27) // 128M terms
#define IC_DEFAULT_STACK_SIZE (1UL << 24) // 16M terms
#endif
// -----------------------------------------------------------------------------
// Core Types and Constants
// -----------------------------------------------------------------------------
#ifdef IC_64BIT
typedef enum {
VAR = 0x00, // Variable
LAM = 0x01, // Lambda
APP = 0x02, // Application
ERA = 0x03, // Erasure
NUM = 0x04, // Number
SUC = 0x05, // Successor
SWI = 0x06, // Switch
SUP = 0x07, // Superposition
DPX = 0x08, // Duplication variable 0
DPY = 0x09, // Duplication variable 1
} TermTag;
// Term 64-bit packed representation
typedef uint64_t Term;
typedef uint64_t Val;
typedef uint16_t Lab;
// Term components
#define TERM_SUB_MASK 0x8000000000000000ULL // 1-bit: Is this a substitution?
#define TERM_TAG_MASK 0x7F00000000000000ULL // 7-bits: Term tag
#define TERM_LAB_MASK 0x00FFFF0000000000ULL // 16-bits: Label
#define TERM_VAL_MASK 0x000000FFFFFFFFFFULL // 40-bits: Value/pointer
#define NONE 0xFFFFFFFFFFFFFFFFULL
#define LAB_MAX 0xFFFF
// Term component extraction
#define TERM_SUB(term) (((term) & TERM_SUB_MASK) != 0)
#define TERM_TAG(term) ((TermTag)(((term) & TERM_TAG_MASK) >> 56))
#define TERM_VAL(term) ((term) & TERM_VAL_MASK)
// Label helpers (for compatibility with existing code)
#define TERM_LAB(term) ((Lab)(((term) & TERM_LAB_MASK) >> 40))
#define IS_SUP(tag) ((tag) == SUP)
#define IS_DP0(tag) ((tag) == DPX)
#define IS_DP1(tag) ((tag) == DPY)
#define IS_DUP(tag) ((tag) == DPX || (tag) == DPY)
#define IS_ERA(tag) ((tag) == ERA)
#define IS_NUM(tag) ((tag) == NUM)
#define IS_SUC(tag) ((tag) == SUC)
#define IS_SWI(tag) ((tag) == SWI)
#define SUP_BASE_TAG ((TermTag)(SUP))
#define DP0_BASE_TAG ((TermTag)(DPX))
#define DP1_BASE_TAG ((TermTag)(DPY))
#define MAKE_TERM(sub, tag, lab, val) \
(((sub) ? TERM_SUB_MASK : 0) | \
(((Term)(tag) << 56)) | \
(((Term)(lab) << 40)) | \
((Term)(val) & TERM_VAL_MASK))
#else
typedef enum {
VAR = 0x00, // Variable
LAM = 0x01, // Lambda
APP = 0x02, // Application
ERA = 0x03, // Erasure
NUM = 0x04, // Number
SUC = 0x05, // Successor
SWI = 0x06, // Switch
TMP = 0x07, // Temporary
SP0 = 0x08, // Superposition with label 0
SP1 = 0x09, // Superposition with label 1
SP2 = 0x0A, // Superposition with label 2
SP3 = 0x0B, // Superposition with label 3
SP4 = 0x0C, // Superposition with label 4
SP5 = 0x0D, // Superposition with label 5
SP6 = 0x0E, // Superposition with label 6
SP7 = 0x0F, // Superposition with label 7
DX0 = 0x10, // Duplication variable 0 with label 0
DX1 = 0x11, // Duplication variable 0 with label 1
DX2 = 0x12, // Duplication variable 0 with label 2
DX3 = 0x13, // Duplication variable 0 with label 3
DX4 = 0x14, // Duplication variable 0 with label 4
DX5 = 0x15, // Duplication variable 0 with label 5
DX6 = 0x16, // Duplication variable 0 with label 6
DX7 = 0x17, // Duplication variable 0 with label 7
DY0 = 0x18, // Duplication variable 1 with label 0
DY1 = 0x19, // Duplication variable 1 with label 1
DY2 = 0x1A, // Duplication variable 1 with label 2
DY3 = 0x1B, // Duplication variable 1 with label 3
DY4 = 0x1C, // Duplication variable 1 with label 4
DY5 = 0x1D, // Duplication variable 1 with label 5
DY6 = 0x1E, // Duplication variable 1 with label 6
DY7 = 0x1F, // Duplication variable 1 with label 7
} TermTag;
// Term 32-bit packed representation
typedef uint32_t Term;
typedef uint32_t Val;
typedef uint8_t Lab;
// Term components
#define TERM_SUB_MASK 0x80000000UL // 1-bit: Is this a substitution?
#define TERM_TAG_MASK 0x7C000000UL // 5-bits: Term tag
#define TERM_VAL_MASK 0x03FFFFFFUL // 26-bits: Value/pointer
#define NONE 0xFFFFFFFF
#define LAB_MAX 0x7
// Term component extraction
#define TERM_SUB(term) (((term) & TERM_SUB_MASK) != 0)
#define TERM_TAG(term) ((TermTag)(((term) & TERM_TAG_MASK) >> 26))
#define TERM_VAL(term) ((term) & TERM_VAL_MASK)
// Label helpers (for compatibility with existing code)
#define TERM_LAB(term) ((TERM_TAG(term) & LAB_MAX)) // Extract label from tag (last 3 bits)
#define IS_SUP(tag) ((tag) >= SP0 && (tag) <= SP7)
#define IS_DP0(tag) ((tag) >= DX0 && (tag) <= DX7)
#define IS_DP1(tag) ((tag) >= DY0 && (tag) <= DY7)
#define IS_DUP(tag) ((tag) >= DX0 && (tag) <= DY7)
#define IS_ERA(tag) ((tag) == ERA)
#define IS_NUM(tag) ((tag) == NUM)
#define IS_SUC(tag) ((tag) == SUC)
#define IS_SWI(tag) ((tag) == SWI)
#define SUP_BASE_TAG ((TermTag)(SP0))
#define DP0_BASE_TAG ((TermTag)(DX0))
#define DP1_BASE_TAG ((TermTag)(DY0))
// Term creation
#define MAKE_TERM(sub, tag, lab, val) \
(((sub) ? TERM_SUB_MASK : 0) | \
(((Term)(tag + lab) << 26)) | \
((Term)(val) & TERM_VAL_MASK))
#endif
// -----------------------------------------------------------------------------
// IC Structure
// -----------------------------------------------------------------------------
// The main Interaction Calculus context structure.
// Contains all state needed for term evaluation.
typedef struct {
// Memory management
Term* heap; // Heap memory for terms
Val heap_size; // Total size of the heap
Val heap_pos; // Current allocation position
// Evaluation stack
Term* stack; // Stack for term evaluation
Val stack_size; // Total size of the stack
Val stack_pos; // Current stack position
// Statistics
uint64_t interactions; // Interaction counter
} IC;
// -----------------------------------------------------------------------------
// IC Functions
// -----------------------------------------------------------------------------
#ifdef HAVE_METAL
// Forward declarations for Metal functions
bool metal_is_available();
void metal_execute_sup_reduction(uint32_t* heap, uint32_t sup_count, uint32_t* sup_indices);
#endif
// Create a new IC context with the specified heap and stack sizes.
// @param heap_size Number of terms in the heap
// @param stack_size Number of terms in the stack
// @return A new IC context or NULL if allocation failed
IC* ic_new(Val heap_size, Val stack_size);
// Create a new IC context with default heap and stack sizes.
// @return A new IC context or NULL if allocation failed
IC* ic_default_new();
// Free all resources associated with an IC context.
// @param ic The IC context to free
void ic_free(IC* ic);
// Allocate n consecutive terms in the heap.
// @param ic The IC context
// @param n Number of terms to allocate
// @return The starting location of the allocated block
Val ic_alloc(IC* ic, Val n);
// Create a term with the given tag and value.
// @param tag The term's tag
// @param lab The term's label
// @param val The term's value (typically a heap location)
// @return The constructed term
Term ic_make_term(TermTag tag, Lab lab, Val val);
// Create a substitution term by setting the substitution bit.
// @param term The term to convert to a substitution
// @return The term with its substitution bit set
Term ic_make_sub(Term term);
// Clear the substitution bit from a term.
// @param term The term to clear
// @return The term with its substitution bit cleared
Term ic_clear_sub(Term term);
// Term constructors.
Term ic_make_sup(Lab lab, Val val);
Term ic_make_co0(Lab lab, Val val);
Term ic_make_co1(Lab lab, Val val);
Term ic_make_era();
Term ic_make_num(Val val);
Term ic_make_suc(Val val);
Term ic_make_swi(Val val);
// Check if a term is an erasure term.
// @param term The term to check
// @return True if the term is an erasure, false otherwise
bool ic_is_era(Term term);
// Allocate a node in the heap.
Val ic_lam(IC* ic, Term bod);
Val ic_app(IC* ic, Term fun, Term arg);
Val ic_sup(IC* ic, Term lft, Term rgt);
Val ic_dup(IC* ic, Term val);
Val ic_suc(IC* ic, Term num);
Val ic_swi(IC* ic, Term num, Term ifz, Term ifs);
// Interactions
Term ic_app_lam(IC* ic, Term app, Term lam);
Term ic_app_sup(IC* ic, Term app, Term sup);
Term ic_app_era(IC* ic, Term app, Term era);
Term ic_dup_lam(IC* ic, Term dup, Term lam);
Term ic_dup_sup(IC* ic, Term dup, Term sup);
Term ic_dup_era(IC* ic, Term dup, Term era);
// Numeric interactions
Term ic_suc_num(IC* ic, Term suc, Term num);
Term ic_suc_era(IC* ic, Term suc, Term era);
Term ic_suc_sup(IC* ic, Term suc, Term sup);
Term ic_swi_num(IC* ic, Term swi, Term num);
Term ic_swi_era(IC* ic, Term swi, Term era);
Term ic_swi_sup(IC* ic, Term swi, Term sup);
Term ic_dup_num(IC* ic, Term dup, Term num);
// Reduce a term to weak head normal form (WHNF).
// @param ic The IC context
// @param term The term to reduce
// @return The term in WHNF
Term ic_whnf(IC* ic, Term term);
// Reduce a term to full normal form by recursively normalizing subterms.
// @param ic The IC context
// @param term The term to normalize
// @return The normalized term
Term ic_normal(IC* ic, Term term);
#endif // IC_H
================================================
FILE: src/ic.metal
================================================
#include <metal_stdlib>
#include <metal_atomic>
using namespace metal;
/**
* Interaction Calculus (IC) - Metal implementation
*
* This file contains the Metal GPU implementation of the Interaction Calculus:
* - Term representation and bit manipulation
* - Core interactions (app_lam, app_sup, col_lam, col_sup)
* - Weak Head Normal Form (WHNF) reduction
* - Full Normal Form reduction
*/
// Core Term representation and constants (aligned with ic.h)
typedef uint32_t Term;
// Term tags (matching the enum in ic.h)
constant uint VAR = 0;
constant uint SUP = 1;
constant uint DP0 = 2;
constant uint DP1 = 3;
constant uint LAM = 4;
constant uint APP = 5;
// Term components
constant uint32_t TERM_SUB_MASK = 0x80000000;
constant uint32_t TERM_TAG_MASK = 0x70000000;
constant uint32_t TERM_LAB_MASK = 0x0C000000;
constant uint32_t TERM_VAL_MASK = 0x03FFFFFF;
// -----------------------------------------------------------------------------
// Term Manipulation Macros
// -----------------------------------------------------------------------------
#define M_IC_MAKE_SUB(term) ((term) | TERM_SUB_MASK)
#define M_IC_CLEAR_SUB(term) ((term) & ~TERM_SUB_MASK)
#define M_IC_GET_TAG(term) (((term) & TERM_TAG_MASK) >> 28)
#define M_IC_GET_LAB(term) (((term) & TERM_LAB_MASK) >> 26)
#define M_IC_GET_VAL(term) ((term) & TERM_VAL_MASK)
#define M_IC_MAKE_TERM(tag, lab, val) \
(((uint32_t)(tag) << 28) | ((uint32_t)(lab) << 26) | ((uint32_t)(val) & TERM_VAL_MASK))
// Key constants for faster case switching
#define INTERACTION_APP_LAM ((APP << 3) | LAM)
#define INTERACTION_APP_SUP ((APP << 3) | SUP)
// -----------------------------------------------------------------------------
// Memory Management Functions
// -----------------------------------------------------------------------------
/**
* Allocate n consecutive terms in memory.
* @param heap_pos Current heap position reference
* @param n Number of terms to allocate
* @param heap_size Total size of the heap
* @return Location in the heap
*/
inline uint32_t m_ic_alloc(device uint32_t& heap_pos, uint32_t n,
constant uint32_t& heap_size) {
uint32_t ptr = heap_pos;
heap_pos += n;
// Bounds check
if (heap_pos >= heap_size) {
// Cap at maximum size as a safeguard
heap_pos = heap_size - 1;
}
return ptr;
}
// -----------------------------------------------------------------------------
// Interaction Functions
// -----------------------------------------------------------------------------
/**
* Apply a lambda to an argument.
* @param heap Heap memory
* @param interactions Interaction counter
* @param app Application term
* @param lam Lambda term
* @return Result of the interaction
*/
inline Term m_ic_app_lam(device Term* heap, device atomic_uint& interactions,
Term app, Term lam) {
atomic_fetch_add_explicit(&interactions, 1, memory_order_relaxed);
// Extract locations
const uint32_t app_loc = M_IC_GET_VAL(app);
const uint32_t lam_loc = M_IC_GET_VAL(lam);
// Load arguments
const Term arg = heap[app_loc + 1];
const Term bod = heap[lam_loc + 0];
// Create substitution for the lambda variable
heap[lam_loc] = M_IC_MAKE_SUB(arg);
return bod;
}
/**
* Apply a function to a superposition.
* @param heap Heap memory
* @param interactions Interaction counter
* @param heap_pos Current heap position
* @param heap_size Total heap size
* @param app Application term
* @param sup Superposition term
* @return Result of the interaction
*/
inline Term m_ic_app_sup(device Term* heap, device atomic_uint& interactions,
device uint32_t& heap_pos, constant uint32_t& heap_size,
Term app, Term sup) {
atomic_fetch_add_explicit(&interactions, 1, memory_order_relaxed);
// Cache frequent values
const uint32_t app_loc = M_IC_GET_VAL(app);
const uint32_t sup_loc = M_IC_GET_VAL(sup);
const uint8_t sup_lab = M_IC_GET_LAB(sup);
// Load arguments
const Term arg = heap[app_loc + 1];
const Term rgt = heap[sup_loc + 1];
// Allocate memory
const uint32_t col_loc = m_ic_alloc(heap_pos, 1, heap_size);
const uint32_t app1_loc = m_ic_alloc(heap_pos, 2, heap_size);
// Store arg in collapser location
heap[col_loc] = arg;
// Create DP0 and DP1 terms
const Term x0 = M_IC_MAKE_TERM(DP0, sup_lab, col_loc);
const Term x1 = M_IC_MAKE_TERM(DP1, sup_lab, col_loc);
// Reuse sup_loc for app0 (lft is already in heap[sup_loc + 0])
heap[sup_loc + 1] = x0;
// Set up app1
heap[app1_loc + 0] = rgt;
heap[app1_loc + 1] = x1;
// Reuse app_loc for result superposition
heap[app_loc + 0] = M_IC_MAKE_TERM(APP, 0, sup_loc);
heap[app_loc + 1] = M_IC_MAKE_TERM(APP, 0, app1_loc);
// Return the final result
return M_IC_MAKE_TERM(SUP, sup_lab, app_loc);
}
/**
* Collapse a lambda.
* @param heap Heap memory
* @param interactions Interaction counter
* @param heap_pos Current heap position
* @param heap_size Total heap size
* @param col Duplication term
* @param lam Lambda term
* @return Result of the interaction
*/
inline Term m_ic_col_lam(device Term* heap, device atomic_uint& interactions,
device uint32_t& heap_pos, constant uint32_t& heap_size,
Term col, Term lam) {
atomic_fetch_add_explicit(&interactions, 1, memory_order_relaxed);
// Cache frequent values
const uint32_t col_loc = M_IC_GET_VAL(col);
const uint32_t lam_loc = M_IC_GET_VAL(lam);
const uint8_t col_lab = M_IC_GET_LAB(col);
const uint8_t is_co0 = (M_IC_GET_TAG(col) == DP0);
// Load body
const Term bod = heap[lam_loc + 0];
// Batch allocate memory for efficiency
const uint32_t alloc_start = m_ic_alloc(heap_pos, 5, heap_size);
const uint32_t lam0_loc = alloc_start;
const uint32_t lam1_loc = alloc_start + 1;
const uint32_t sup_loc = alloc_start + 2; // 2 locations
const uint32_t col_new_loc = alloc_start + 4;
// Set up superposition
heap[sup_loc + 0] = M_IC_MAKE_TERM(VAR, 0, lam0_loc);
heap[sup_loc + 1] = M_IC_MAKE_TERM(VAR, 0, lam1_loc);
// Replace lambda's variable with the superposition
heap[lam_loc] = M_IC_MAKE_SUB(M_IC_MAKE_TERM(SUP, col_lab, sup_loc));
// Set up the new collapser
heap[col_new_loc] = bod;
// Set up new lambda bodies
heap[lam0_loc] = M_IC_MAKE_TERM(DP0, col_lab, col_new_loc);
heap[lam1_loc] = M_IC_MAKE_TERM(DP1, col_lab, col_new_loc);
// Create and return the appropriate lambda
if (is_co0) {
heap[col_loc] = M_IC_MAKE_SUB(M_IC_MAKE_TERM(LAM, 0, lam1_loc));
return M_IC_MAKE_TERM(LAM, 0, lam0_loc);
} else {
heap[col_loc] = M_IC_MAKE_SUB(M_IC_MAKE_TERM(LAM, 0, lam0_loc));
return M_IC_MAKE_TERM(LAM, 0, lam1_loc);
}
}
/**
* Collapse a superposition.
* @param heap Heap memory
* @param interactions Interaction counter
* @param heap_pos Current heap position
* @param heap_size Total heap size
* @param col Duplication term
* @param sup Superposition term
* @return Result of the interaction
*/
inline Term m_ic_col_sup(device Term* heap, device atomic_uint& interactions,
device uint32_t& heap_pos, constant uint32_t& heap_size,
Term col, Term sup) {
atomic_fetch_add_explicit(&interactions, 1, memory_order_relaxed);
// Cache frequent values
const uint32_t col_loc = M_IC_GET_VAL(col);
const uint32_t sup_loc = M_IC_GET_VAL(sup);
const uint8_t col_lab = M_IC_GET_LAB(col);
const uint8_t sup_lab = M_IC_GET_LAB(sup);
const uint8_t is_co0 = (M_IC_GET_TAG(col) == DP0);
// Load values needed for both paths
const Term lft = heap[sup_loc + 0];
const Term rgt = heap[sup_loc + 1];
// Fast path for matching labels (common case)
if (col_lab == sup_lab) {
// Labels match: simple substitution
if (is_co0) {
heap[col_loc] = M_IC_MAKE_SUB(rgt);
return lft;
} else {
heap[col_loc] = M_IC_MAKE_SUB(lft);
return rgt;
}
} else {
// Labels don't match: create nested collapsers
const uint32_t sup_start = m_ic_alloc(heap_pos, 4, heap_size); // 2 sups with 2 terms each
const uint32_t sup0_loc = sup_start;
const uint32_t sup1_loc = sup_start + 2;
// Use existing locations as collapser locations
const uint32_t col_lft_loc = sup_loc + 0;
const uint32_t col_rgt_loc = sup_loc + 1;
// Set up the first superposition (for DP0)
heap[sup0_loc + 0] = M_IC_MAKE_TERM(DP0, col_lab, col_lft_loc);
heap[sup0_loc + 1] = M_IC_MAKE_TERM(DP0, col_lab, col_rgt_loc);
// Set up the second superposition (for DP1)
heap[sup1_loc + 0] = M_IC_MAKE_TERM(DP1, col_lab, col_lft_loc);
heap[sup1_loc + 1] = M_IC_MAKE_TERM(DP1, col_lab, col_rgt_loc);
// Set up original collapsers to point to lft and rgt
heap[col_lft_loc] = lft;
heap[col_rgt_loc] = rgt;
if (is_co0) {
heap[col_loc] = M_IC_MAKE_SUB(M_IC_MAKE_TERM(SUP, sup_lab, sup1_loc));
return M_IC_MAKE_TERM(SUP, sup_lab, sup0_loc);
} else {
heap[col_loc] = M_IC_MAKE_SUB(M_IC_MAKE_TERM(SUP, sup_lab, sup0_loc));
return M_IC_MAKE_TERM(SUP, sup_lab, sup1_loc);
}
}
}
// -----------------------------------------------------------------------------
// Term Normalization
// -----------------------------------------------------------------------------
/**
* Reduce a term to weak head normal form (WHNF).
* @param heap Heap memory
* @param stack Evaluation stack
* @param stack_pos Current stack position reference
* @param stack_size Total stack size
* @param heap_pos Current heap position reference
* @param heap_size Total heap size
* @param interactions Interaction counter
* @param term The term to reduce
* @return The term in WHNF
*/
inline Term m_ic_whnf(device Term* heap, device Term* stack,
device uint32_t& stack_pos, constant uint32_t& stack_size,
device uint32_t& heap_pos, constant uint32_t& heap_size,
device atomic_uint& interactions, Term term) {
// Cache frequently used variables in registers
uint32_t stop = stack_pos;
Term next = term;
uint32_t sp = stop;
// Main normalization loop
while (true) {
// Get tag with optimized macro
const uint tag = M_IC_GET_TAG(next);
switch (tag) {
case VAR: {
// Variable case
const uint32_t var_loc = M_IC_GET_VAL(next);
const Term subst = heap[var_loc];
if (subst & TERM_SUB_MASK) { // Direct bit test
next = M_IC_CLEAR_SUB(subst);
continue;
}
break; // No substitution, so it's in WHNF
}
case DP0:
case DP1: {
// Duplication case
const uint32_t col_loc = M_IC_GET_VAL(next);
const Term val = heap[col_loc];
if (val & TERM_SUB_MASK) { // Direct bit test
next = M_IC_CLEAR_SUB(val);
continue;
} else {
// Push to stack
if (sp < stack_size) {
stack[sp++] = next;
next = val;
continue;
} else {
// Stack overflow
break;
}
}
}
case APP: {
// Application case
const uint32_t app_loc = M_IC_GET_VAL(next);
// Push to stack
if (sp < stack_size) {
stack[sp++] = next;
next = heap[app_loc]; // Reduce the function part
continue;
} else {
// Stack overflow
break;
}
}
default: { // SUP, LAM
// Handle default case (SUP, LAM)
if (sp == stop) {
stack_pos = sp; // Update stack position before return
return next; // Stack empty, term is in WHNF
} else {
// Pop from stack
Term prev = stack[--sp];
// Get tag
const uint ptag = M_IC_GET_TAG(prev);
// Handle interactions based on term types
if (ptag == APP && tag == LAM) {
next = m_ic_app_lam(heap, interactions, prev, next);
continue;
}
else if (ptag == APP && tag == SUP) {
next = m_ic_app_sup(heap, interactions, heap_pos, heap_size, prev, next);
continue;
}
else if ((ptag == DP0 || ptag == DP1) && tag == LAM) {
next = m_ic_col_lam(heap, interactions, heap_pos, heap_size, prev, next);
continue;
}
else if ((ptag == DP0 || ptag == DP1) && tag == SUP) {
next = m_ic_col_sup(heap, interactions, heap_pos, heap_size, prev, next);
continue;
}
// No interaction found, return to stack
stack[sp++] = prev;
break;
}
}
}
// After processing, check stack and update heap if needed
if (sp == stop) {
stack_pos = sp;
return next; // Stack empty, return WHNF
} else {
// Process remaining stack
while (sp > stop) {
// Direct stack access
Term host = stack[--sp];
// Extract components
const uint htag = M_IC_GET_TAG(host);
const uint32_t hloc = M_IC_GET_VAL(host);
// Update the heap with the reduced term - only for specific tags
if (htag == APP || htag == DP0 || htag == DP1) {
heap[hloc] = next;
}
next = host;
}
stack_pos = sp;
return next; // Return updated original term
}
}
}
/**
* Reduce a term to full normal form by recursively applying WHNF
* to all subterms.
*
* @param heap Heap memory
* @param stack Evaluation stack
* @param stack_pos Current stack position reference
* @param stack_size Total stack size
* @param heap_pos Current heap position reference
* @param heap_size Total heap size
* @param interactions Interaction counter
* @param term The term to normalize
* @return The fully normalized term
*/
inline Term m_ic_normal(device Term* heap, device Term* stack,
device uint32_t& stack_pos, constant uint32_t& stack_size,
device uint32_t& heap_pos, constant uint32_t& heap_size,
device atomic_uint& interactions, Term term) {
// Reset stack
stack_pos = 0;
uint32_t sp = 0;
// Allocate a new node for the initial term
uint32_t root_loc = m_ic_alloc(heap_pos, 1, heap_size);
heap[root_loc] = term;
// Push initial location to stack
stack[sp++] = (root_loc & TERM_VAL_MASK);
// Main normalization loop
while (sp > 0) {
// Pop current location from stack
const uint32_t loc = stack[--sp] & TERM_VAL_MASK;
// Get term at this location
Term current = heap[loc];
// Reduce to WHNF
stack_pos = sp;
current = m_ic_whnf(heap, stack, stack_pos, stack_size,
heap_pos, heap_size, interactions, current);
sp = stack_pos;
// Store the WHNF term back to the heap
heap[loc] = current;
// Get term details
const uint tag = M_IC_GET_TAG(current);
const uint32_t val = M_IC_GET_VAL(current);
// Push subterm locations based on term type
if (tag == LAM) {
if (sp < stack_size) {
stack[sp++] = val & TERM_VAL_MASK;
}
}
else if (tag == APP || tag == SUP) {
// Both APP and SUP need to push two locations
if (sp + 1 < stack_size) {
stack[sp++] = val & TERM_VAL_MASK;
stack[sp++] = (val + 1) & TERM_VAL_MASK;
}
}
// Other tags have no subterms to process
}
// Update stack position and return the fully normalized term
stack_pos = sp;
return heap[root_loc];
}
/**
* Main Metal kernel function to normalize a term.
*/
kernel void normalizeKernel(device Term* heap [[buffer(0)]],
device Term* stack [[buffer(1)]],
device uint32_t& heap_pos [[buffer(2)]],
device uint32_t& stack_pos [[buffer(3)]],
device atomic_uint& interactions [[buffer(4)]],
constant uint32_t& heap_size [[buffer(5)]],
constant uint32_t& stack_size [[buffer(6)]],
uint gid [[thread_position_in_grid]]) {
// Only use thread 0 in the grid
if (gid == 0) {
// Get the term from the heap's entry point
Term term = heap[0];
// Perform normalization
term = m_ic_normal(heap, stack, stack_pos, stack_size,
heap_pos, heap_size, interactions, term);
// Store the result back to the heap's entry point
heap[0] = term;
}
}
================================================
FILE: src/ic_metal.mm
================================================
#import <Foundation/Foundation.h>
#import <Metal/Metal.h>
#include "ic.h"
/**
* Interaction Calculus (IC) - Metal Objective-C++ bridge file
*
* This file provides the bridge between the main C implementation
* and the Metal GPU implementation for accelerated normalization:
* - Metal context creation and management
* - Metal device, command queue, and pipeline setup
* - Metal buffer management and synchronization
*/
// Structure to hold Metal-specific resources
typedef struct {
id<MTLDevice> device;
id<MTLCommandQueue> commandQueue;
id<MTLLibrary> library;
id<MTLFunction> normalizeFunction;
id<MTLComputePipelineState> normalizePipeline;
id<MTLBuffer> heapBuffer;
id<MTLBuffer> stackBuffer;
id<MTLBuffer> heapPosBuffer;
id<MTLBuffer> stackPosBuffer;
id<MTLBuffer> interactionsBuffer;
id<MTLBuffer> heapSizeBuffer;
id<MTLBuffer> stackSizeBuffer;
bool initialized;
} MetalContext;
// Global Metal context
static MetalContext metalContext = {0};
/**
* Initialize the Metal environment.
* @return true if initialization was successful, false otherwise
*/
static bool initMetal() {
@autoreleasepool {
// Get the default Metal device
metalContext.device = MTLCreateSystemDefaultDevice();
if (!metalContext.device) {
fprintf(stderr, "Metal: Error creating system default device\n");
return false;
}
// Create command queue
metalContext.commandQueue = [metalContext.device newCommandQueue];
if (!metalContext.commandQueue) {
fprintf(stderr, "Metal: Error creating command queue\n");
return false;
}
// Load Metal library from the default bundle
NSError* error = nil;
NSString* metalLibraryPath = [[NSBundle mainBundle] pathForResource:@"ic" ofType:@"metallib"];
if (metalLibraryPath) {
// Load pre-compiled library if available
NSURL* metalLibraryURL = [NSURL fileURLWithPath:metalLibraryPath];
metalContext.library = [metalContext.device newLibraryWithURL:metalLibraryURL error:&error];
} else {
// If no pre-compiled library, load the source code and compile it
NSString* shaderSource = [[NSBundle mainBundle] pathForResource:@"ic" ofType:@"metal"];
if (shaderSource) {
metalContext.library = [metalContext.device newLibraryWithSource:shaderSource
options:nil
error:&error];
} else {
// As a last resort, use the shader source from the implementation file
NSString* shaderPath = [[NSBundle mainBundle] pathForResource:@"ic" ofType:@"metal"];
NSString* shaderSource = [NSString stringWithContentsOfFile:shaderPath
encoding:NSUTF8StringEncoding
error:&error];
if (shaderSource) {
metalContext.library = [metalContext.device newLibraryWithSource:shaderSource
options:nil
error:&error];
}
}
}
if (!metalContext.library) {
fprintf(stderr, "Metal: Error creating library: %s\n",
error ? [[error localizedDescription] UTF8String] : "unknown error");
return false;
}
// Get the normalize function from the library
metalContext.normalizeFunction = [metalContext.library newFunctionWithName:@"normalizeKernel"];
if (!metalContext.normalizeFunction) {
fprintf(stderr, "Metal: Failed to find the normalizeKernel function\n");
return false;
}
// Create compute pipeline
metalContext.normalizePipeline = [metalContext.device newComputePipelineStateWithFunction:metalContext.normalizeFunction
error:&error];
if (!metalContext.normalizePipeline) {
fprintf(stderr, "Metal: Error creating compute pipeline: %s\n",
[[error localizedDescription] UTF8String]);
return false;
}
metalContext.initialized = true;
return true;
}
}
/**
* Check if Metal is available on this system.
* @return 1 if Metal is available, 0 otherwise
*/
extern "C" int ic_metal_available() {
@autoreleasepool {
id<MTLDevice> device = MTLCreateSystemDefaultDevice();
return device != nil;
}
}
/**
* Normalize a term using Metal.
* @param ic The IC context
* @param term The term to normalize
* @return The normalized term
*/
extern "C" Term ic_normal_metal(IC* ic, Term term) {
@autoreleasepool {
// Initialize Metal if not already done
if (!metalContext.initialized) {
if (!initMetal()) {
fprintf(stderr, "Metal: Failed to initialize Metal. Falling back to CPU.\n");
return term;
}
}
// Get heap and stack parameters
uint32_t heap_size = ic->heap_size;
uint32_t stack_size = ic->stack_size;
uint32_t heap_pos = ic->heap_pos;
uint32_t stack_pos = 0;
uint32_t interactions = 0; // Use uint32_t for Metal compatibility
// Create Metal buffers
metalContext.heapBuffer = [metalContext.device newBufferWithLength:heap_size * sizeof(Term)
options:MTLResourceStorageModeShared];
metalContext.stackBuffer = [metalContext.device newBufferWithLength:stack_size * sizeof(Term)
options:MTLResourceStorageModeShared];
metalContext.heapPosBuffer = [metalContext.device newBufferWithBytes:&heap_pos
length:sizeof(uint32_t)
options:MTLResourceStorageModeShared];
metalContext.stackPosBuffer = [metalContext.device newBufferWithBytes:&stack_pos
length:sizeof(uint32_t)
options:MTLResourceStorageModeShared];
metalContext.interactionsBuffer = [metalContext.device newBufferWithBytes:&interactions
length:sizeof(uint32_t)
options:MTLResourceStorageModeShared];
metalContext.heapSizeBuffer = [metalContext.device newBufferWithBytes:&heap_size
length:sizeof(uint32_t)
options:MTLResourceStorageModeShared];
metalContext.stackSizeBuffer = [metalContext.device newBufferWithBytes:&stack_size
length:sizeof(uint32_t)
options:MTLResourceStorageModeShared];
// Verify buffer allocation
if (!metalContext.heapBuffer || !metalContext.stackBuffer ||
!metalContext.heapPosBuffer || !metalContext.stackPosBuffer ||
!metalContext.interactionsBuffer || !metalContext.heapSizeBuffer ||
!metalContext.stackSizeBuffer) {
fprintf(stderr, "Metal: Failed to create buffers\n");
return term;
}
// Copy heap data to the Metal buffer
Term* heapData = (Term*)metalContext.heapBuffer.contents;
memcpy(heapData, ic->heap, ic->heap_pos * sizeof(Term));
// Set up Metal command execution
id<MTLCommandBuffer> commandBuffer = [metalContext.commandQueue commandBuffer];
id<MTLComputeCommandEncoder> computeEncoder = [commandBuffer computeCommandEncoder];
// Configure the compute command encoder
[computeEncoder setComputePipelineState:metalContext.normalizePipeline];
// Set buffer arguments for the kernel
[computeEncoder setBuffer:metalContext.heapBuffer offset:0 atIndex:0];
[computeEncoder setBuffer:metalContext.stackBuffer offset:0 atIndex:1];
[computeEncoder setBuffer:metalContext.heapPosBuffer offset:0 atIndex:2];
[computeEncoder setBuffer:metalContext.stackPosBuffer offset:0 atIndex:3];
[computeEncoder setBuffer:metalContext.interactionsBuffer offset:0 atIndex:4];
[computeEncoder setBuffer:metalContext.heapSizeBuffer offset:0 atIndex:5];
[computeEncoder setBuffer:metalContext.stackSizeBuffer offset:0 atIndex:6];
// Configure grid and threadgroup sizes
MTLSize gridSize = MTLSizeMake(1, 1, 1);
MTLSize threadGroupSize = MTLSizeMake(1, 1, 1);
// Dispatch the kernel
[computeEncoder dispatchThreadgroups:gridSize threadsPerThreadgroup:threadGroupSize];
[computeEncoder endEncoding];
// Add completion handler
[commandBuffer addCompletedHandler:^(id<MTLCommandBuffer> buffer) {
if (buffer.error) {
NSLog(@"Metal: Command buffer execution failed: %@", buffer.error);
}
}];
// Execute the command buffer
[commandBuffer commit];
[commandBuffer waitUntilCompleted];
// Read back results
heap_pos = *(uint32_t*)metalContext.heapPosBuffer.contents;
stack_pos = *(uint32_t*)metalContext.stackPosBuffer.contents;
interactions = *(uint32_t*)metalContext.interactionsBuffer.contents;
// Copy data back from Metal buffer to IC heap
memcpy(ic->heap, heapData, heap_pos * sizeof(Term));
// Update IC state
ic->heap_pos = heap_pos;
ic->interactions += interactions;
// Return the normalized term
return ic->heap[0];
}
}
/**
* Compile the Metal shader file.
* @param metal_file_path Path to the Metal shader file
* @return true if compilation was successful, false otherwise
*/
extern "C" bool ic_metal_compile_shader(const char* metal_file_path) {
@autoreleasepool {
// Initialize Metal if not already done
if (!metalContext.initialized) {
if (!initMetal()) {
return false;
}
}
NSError* error = nil;
NSString* sourcePath = [NSString stringWithUTF8String:metal_file_path];
NSString* shaderSource = [NSString stringWithContentsOfFile:sourcePath
encoding:NSUTF8StringEncoding
error:&error];
if (!shaderSource) {
fprintf(stderr, "Metal: Error reading shader source: %s\n",
error ? [[error localizedDescription] UTF8String] : "unknown error");
return false;
}
// Compile the shader
id<MTLLibrary> library = [metalContext.device newLibraryWithSource:shaderSource
options:nil
error:&error];
if (!library) {
fprintf(stderr, "Metal: Error compiling shader: %s\n",
error ? [[error localizedDescription] UTF8String] : "unknown error");
return false;
}
// Check that our function exists
id<MTLFunction> normalizeFunction = [library newFunctionWithName:@"normalizeKernel"];
if (!normalizeFunction) {
fprintf(stderr, "Metal: Failed to find the normalizeKernel function\n");
return false;
}
printf("Metal: Shader compiled successfully\n");
return true;
}
}
================================================
FILE: src/main.c
================================================
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <sys/time.h>
#include "ic.h"
#include "collapse.h"
#include "parse.h"
#include "show.h"
// Forward declarations for Metal GPU functions
#ifdef HAVE_METAL
extern Term ic_normal_metal(IC* ic, Term term);
extern int ic_metal_available();
#endif
// Stub functions when Metal is not available
#ifndef HAVE_METAL
static inline int ic_metal_available() {
return 0; // Metal not available
}
static inline Term ic_normal_metal(IC* ic, Term term) {
fprintf(stderr, "Warning: Metal GPU support not compiled. Running on CPU instead.\n");
return ic_normal(ic, term);
}
#endif
// Default test term string
const char* DEFAULT_TEST_TERM = "(λf.λx.(f (f (f x))) λb.(b λt.λf.f λt.λf.t) λt.λf.t)";
// Function declarations
static Term normalize_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count);
static void process_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count);
static void benchmark_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count);
static void test(IC* ic, int use_gpu, int use_collapse, int thread_count);
static void print_usage(void);
// Normalize a term based on mode flags
static Term normalize_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count) {
if (use_collapse) {
if (use_gpu) {
fprintf(stderr, "Warning: Collapse mode is not available for GPU. Using normal GPU normalization.\n");
if (ic_metal_available()) {
return ic_normal_metal(ic, term);
} else {
fprintf(stderr, "Warning: No GPU acceleration available. Falling back to CPU normalization.\n");
return ic_normal(ic, term);
}
} else {
term = ic_collapse_sups(ic, term);
term = ic_collapse_dups(ic, term);
return term;
}
} else {
if (use_gpu) {
if (ic_metal_available()) {
return ic_normal_metal(ic, term);
} else {
fprintf(stderr, "Warning: No GPU acceleration available. Falling back to CPU normalization.\n");
return ic_normal(ic, term);
}
} else {
return ic_normal(ic, term);
}
}
}
// Process and print results of term normalization
static void process_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count) {
ic->interactions = 0; // Reset interaction counter
struct timeval start_time, current_time;
gettimeofday(&start_time, NULL);
term = normalize_term(ic, term, use_gpu, use_collapse, thread_count);
gettimeofday(¤t_time, NULL);
double elapsed_seconds = (current_time.tv_sec - start_time.tv_sec) +
(current_time.tv_usec - start_time.tv_usec) / 1000000.0;
size_t size = ic->heap_pos; // Heap size in nodes
double perf = elapsed_seconds > 0 ? (ic->interactions / elapsed_seconds) / 1000000.0 : 0.0;
// Use namespaced version with '$' prefix when collapse mode is off
if (use_collapse) {
show_term(stdout, ic, term);
} else {
show_term_namespaced(stdout, ic, term, "$");
}
printf("\n\n");
printf("WORK: %llu interactions\n", ic->interactions);
printf("TIME: %.7f seconds\n", elapsed_seconds);
printf("SIZE: %zu nodes\n", size);
printf("PERF: %.3f MIPS\n", perf);
const char* mode_str;
if (use_collapse && !use_gpu) {
mode_str = "CPU (collapse)";
} else if (use_gpu) {
if (ic_metal_available()) {
mode_str = "Metal GPU";
} else {
mode_str = "CPU";
}
} else {
mode_str = "CPU";
}
printf("MODE: %s\n", mode_str);
if (use_gpu && use_collapse) {
printf("Note: Collapse mode is not available for GPU. Used normal GPU normalization.\n");
}
printf("\n");
}
// Benchmark normalization performance over 1 second
static void benchmark_term(IC* ic, Term term, int use_gpu, int use_collapse, int thread_count) {
// Snapshot initial heap state
Val original_heap_pos = ic->heap_pos;
Term* original_heap_state = (Term*)malloc(original_heap_pos * sizeof(Term));
if (!original_heap_state) {
fprintf(stderr, "Error: Memory allocation failed for heap snapshot\n");
return;
}
memcpy(original_heap_state, ic->heap, original_heap_pos * sizeof(Term));
Term original_term = term;
// Normalize once to show result
Term result = normalize_term(ic, term, use_gpu, use_collapse, thread_count);
// Use namespaced version with '$' prefix when collapse mode is off
if (use_collapse) {
show_term(stdout, ic, result);
} else {
show_term_namespaced(stdout, ic, result, "$");
}
printf("\n\n");
// Benchmark loop
uint64_t total_interactions = 0;
uint64_t iterations = 0;
struct timeval start_time, current_time;
gettimeofday(&start_time, NULL);
double elapsed_seconds = 0;
while (elapsed_seconds < 1.0) {
ic->heap_pos = original_heap_pos;
memcpy(ic->heap, original_heap_state, original_heap_pos * sizeof(Term));
ic->interactions = 0;
normalize_term(ic, original_term, use_gpu, use_collapse, thread_count);
total_interactions += ic->interactions;
iterations++;
gettimeofday(¤t_time, NULL);
elapsed_seconds = (current_time.tv_sec - start_time.tv_sec) +
(current_time.tv_usec - start_time.tv_usec) / 1000000.0;
}
double mips = (total_interactions / elapsed_seconds) / 1000000.0;
printf("BENCHMARK:\n");
printf("- LOOP: %u\n", iterations);
printf("- WORK: %llu\n", total_interactions);
printf("- TIME: %.3f seconds\n", elapsed_seconds);
printf("- PERF: %.3f MIPS\n", mips);
const char* mode_str;
if (use_collapse && !use_gpu) {
mode_str = "CPU (collapse)";
} else if (use_gpu) {
if (ic_metal_available()) {
mode_str = "Metal GPU";
} else {
mode_str = "CPU";
}
} else {
mode_str = "CPU";
}
printf("- MODE: %s\n", mode_str);
if (use_gpu && use_collapse) {
printf("- Note: Collapse mode is not available for GPU. Used normal GPU normalization.\n");
}
free(original_heap_state);
}
// Run default test term
static void test(IC* ic, int use_gpu, int use_collapse, int thread_count) {
printf("Running with default test term: %s\n", DEFAULT_TEST_TERM);
Term term = parse_string(ic, DEFAULT_TEST_TERM);
process_term(ic, term, use_gpu, use_collapse, thread_count);
}
// Print command-line usage
static void print_usage(void) {
printf("Usage: ic <command> [arguments] [options]\n\n");
printf("Commands:\n");
printf(" run <file> - Parse and normalize a IC file on CPU\n");
printf(" run-gpu <file> - Parse and normalize a IC file on GPU (Metal)\n");
printf(" eval <expr> - Parse and normalize a IC expression on CPU\n");
printf(" eval-gpu <expr> - Parse and normalize a IC expression on GPU (Metal)\n");
printf(" bench <file> - Benchmark normalization of a IC file on CPU\n");
printf(" bench-gpu <file> - Benchmark normalization of a IC file on GPU (Metal)\n");
printf("\n");
printf("Options:\n");
printf(" -C - Use collapse mode (CPU only)\n");
printf("\n");
}
int main(int argc, char* argv[]) {
IC* ic = ic_default_new();
if (!ic) {
fprintf(stderr, "Error: Failed to initialize IC context\n");
return 1;
}
int result = 0;
int use_gpu = 0;
int use_collapse = 0;
int thread_count = 1;
if (argc < 2) {
test(ic, 0, 0, thread_count);
goto cleanup;
}
const char* command = argv[1];
if (strcmp(command, "run-gpu") == 0 || strcmp(command, "eval-gpu") == 0 || strcmp(command, "bench-gpu") == 0) {
use_gpu = 1;
} else if (strcmp(command, "run") != 0 && strcmp(command, "eval") != 0 && strcmp(command, "bench") != 0) {
fprintf(stderr, "Error: Unknown command '%s'\n", command);
print_usage();
result = 1;
goto cleanup;
}
if (argc < 3) {
fprintf(stderr, "Error: No term source specified\n");
print_usage();
result = 1;
goto cleanup;
}
// Parse flags
for (int i = 3; i < argc; i++) {
if (strcmp(argv[i], "-C") == 0) {
use_collapse = 1;
} else {
fprintf(stderr, "Error: Unknown flag '%s'\n", argv[i]);
print_usage();
result = 1;
goto cleanup;
}
}
// Parse term based on command
Term term;
if (strcmp(command, "eval") == 0 || strcmp(command, "eval-gpu") == 0) {
term = parse_string(ic, argv[2]);
} else { // run, run-gpu, bench, bench-gpu
term = parse_file(ic, argv[2]);
}
// Execute command
if (strcmp(command, "bench") == 0 || strcmp(command, "bench-gpu") == 0) {
benchmark_term(ic, term, use_gpu, use_collapse, thread_count);
} else { // run, run-gpu, eval, eval-gpu
process_term(ic, term, use_gpu, use_collapse, thread_count);
}
cleanup:
ic_free(ic);
return result;
}
================================================
FILE: src/parse.c
================================================
// parse.c
#include "parse.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
// Forward declarations
Val parse_term_alloc(Parser* parser);
void parse_term(Parser* parser, Val loc);
void skip(Parser* parser);
char peek_char(Parser* parser);
char next_char(Parser* parser);
bool peek_is(Parser* parser, char c);
void parse_error(Parser* parser, const char* message);
// Helper functions
static bool starts_with_dollar(const char* name) {
return name[0] == '$';
}
static size_t find_or_add_global_var(Parser* parser, const char* name) {
for (size_t i = 0; i < parser->global_vars_count; i++) {
if (strcmp(parser->global_vars[i].name, name) == 0) {
return i;
}
}
if (parser->global_vars_count >= MAX_GLOBAL_VARS) {
parse_error(parser, "Too many global variables");
}
size_t idx = parser->global_vars_count++;
Binder* binder = &parser->global_vars[idx];
strncpy(binder->name, name, MAX_NAME_LEN - 1);
binder->name[MAX_NAME_LEN - 1] = '\0';
binder->var = NONE;
binder->loc = NONE;
return idx;
}
static void push_lexical_binder(Parser* parser, const char* name, Term term) {
if (parser->lexical_vars_count >= MAX_LEXICAL_VARS) {
parse_error(parser, "Too many lexical binders");
}
Binder* binder = &parser->lexical_vars[parser->lexical_vars_count];
strncpy(binder->name, name, MAX_NAME_LEN - 1);
binder->name[MAX_NAME_LEN - 1] = '\0';
binder->var = term;
binder->loc = NONE;
parser->lexical_vars_count++;
}
static void pop_lexical_binder(Parser* parser) {
if (parser->lexical_vars_count > 0) {
parser->lexical_vars_count--;
}
}
static Binder* find_lexical_binder(Parser* parser, const char* name) {
for (int i = parser->lexical_vars_count - 1; i >= 0; i--) {
if (strcmp(parser->lexical_vars[i].name, name) == 0) {
return &parser->lexical_vars[i];
}
}
return NULL;
}
static void resolve_global_vars(Parser* parser) {
for (size_t i = 0; i < parser->global_vars_count; i++) {
Binder* binder = &parser->global_vars[i];
if (binder->var == NONE) {
char error[256];
snprintf(error, sizeof(error), "Undefined global variable: %s", binder->name);
parse_error(parser, error);
}
if (binder->loc != NONE) {
parser->ic->heap[binder->loc] = binder->var;
}
}
}
static void move_term(Parser* parser, Val from_loc, Val to_loc) {
for (size_t i = 0; i < parser->global_vars_count; i++) {
if (parser->global_vars[i].loc == from_loc) {
parser->global_vars[i].loc = to_loc;
}
}
for (size_t i = 0; i < parser->lexical_vars_count; i++) {
if (parser->lexical_vars[i].loc == from_loc) {
parser->lexical_vars[i].loc = to_loc;
}
}
parser->ic->heap[to_loc] = parser->ic->heap[from_loc];
}
// Parse helper functions
bool consume(Parser* parser, const char* str) {
size_t len = strlen(str);
skip(parser);
if (strncmp(parser->input + parser->pos, str, len) == 0) {
for (size_t i = 0; i < len; i++) {
next_char(parser);
}
return true;
}
return false;
}
void parse_error(Parser* parser, const char* message) {
fprintf(stderr, "Parse error at line %zu, column %zu: %s\n",
parser->line, parser->col, message);
fprintf(stderr, "Input:\n%s\n", parser->input);
fprintf(stderr, " ");
for (size_t i = 0; i < parser->pos && i < 40; i++) {
fprintf(stderr, " ");
}
fprintf(stderr, "^\n");
exit(1);
}
bool expect(Parser* parser, const char* token, const char* error_context) {
if (!consume(parser, token)) {
char error[256];
snprintf(error, sizeof(error), "Expected '%s' %s", token, error_context);
parse_error(parser, error);
return false;
}
return true;
}
void init_parser(Parser* parser, IC* ic, const char* input) {
parser->ic = ic;
parser->input = input;
parser->pos = 0;
parser->line = 1;
parser->col = 1;
parser->global_vars_count = 0;
parser->lexical_vars_count = 0;
}
static void parse_name(Parser* parser, char* name) {
size_t i = 0;
char c = peek_char(parser);
if (!isalpha(c) && c != '_' && c != '$') {
parse_error(parser, "Expected name starting with letter, underscore, or '$'");
}
while (isalnum(peek_char(parser)) || peek_char(parser) == '_' || peek_char(parser) == '$') {
if (i < MAX_NAME_LEN - 1) {
name[i++] = next_char(parser);
} else {
parse_error(parser, "Name too long");
}
}
name[i] = '\0';
}
char next_char(Parser* parser) {
char c = parser->input[parser->pos++];
if (c == '\n') {
parser->line++;
parser->col = 1;
} else {
parser->col++;
}
return c;
}
char peek_char(Parser* parser) {
return parser->input[parser->pos];
}
bool peek_is(Parser* parser, char c) {
return peek_char(parser) == c;
}
void store_term(Parser* parser, Val loc, TermTag tag, Lab lab, Val value) {
parser->ic->heap[loc] = ic_make_term(tag, lab, value);
}
Val parse_uint(Parser* parser) {
Val value = 0;
bool has_digit = false;
while (isdigit(peek_char(parser))) {
value = value * 10 + (next_char(parser) - '0');
has_digit = true;
}
if (!has_digit) {
parse_error(parser, "Expected digit");
}
return value;
}
void skip(Parser* parser) {
while (1) {
char c = peek_char(parser);
if (isspace(c)) {
next_char(parser);
} else if (c == '/' && parser->input[parser->pos + 1] == '/') {
next_char(parser);
next_char(parser);
while (peek_char(parser) != '\0' && peek_char(parser) != '\n') {
next_char(parser);
}
if (peek_char(parser) == '\n') {
next_char(parser);
}
} else {
break;
}
}
}
bool check_utf8(Parser* parser, uint8_t b1, uint8_t b2) {
return (unsigned char)parser->input[parser->pos] == b1 &&
(unsigned char)parser->input[parser->pos + 1] == b2;
}
void consume_utf8(Parser* parser, int bytes) {
for (int i = 0; i < bytes; i++) {
next_char(parser);
}
}
// Term parsing functions
static void parse_term_var(Parser* parser, Val loc) {
char name[MAX_NAME_LEN];
parse_name(parser, name);
if (starts_with_dollar(name)) {
size_t idx = find_or_add_global_var(parser, name);
if (parser->global_vars[idx].var == NONE) {
parser->global_vars[idx].loc = loc;
} else {
parser->ic->heap[loc] = parser->global_vars[idx].var;
}
} else {
Binder* binder = find_lexical_binder(parser, name);
if (binder == NULL) {
char error[256];
snprintf(error, sizeof(error), "Undefined lexical variable: %s", name);
parse_error(parser, error);
}
if (binder->loc == NONE) {
parser->ic->heap[loc] = binder->var;
binder->loc = loc;
} else {
Val dup_loc = ic_alloc(parser->ic, 1);
parser->ic->heap[dup_loc] = parser->ic->heap[binder->loc];
Term dp0 = ic_make_co0(0, dup_loc);
Term dp1 = ic_make_co1(0, dup_loc);
parser->ic->heap[binder->loc] = dp0;
parser->ic->heap[loc] = dp1;
binder->loc = loc;
}
}
}
static void parse_term_lam(Parser* parser, Val loc) {
if (check_utf8(parser, 0xCE, 0xBB)) {
consume_utf8(parser, 2);
} else if (!consume(parser, "λ")) {
parse_error(parser, "Expected 'λ' for lambda");
}
char name[MAX_NAME_LEN];
parse_name(parser, name);
expect(parser, ".", "after name in lambda");
Val lam_node = ic_alloc(parser->ic, 1);
Term var_term = ic_make_term(VAR, 0, lam_node);
if (starts_with_dollar(name)) {
size_t idx = find_or_add_global_var(parser, name);
if (parser->global_vars[idx].var != NONE) {
char error[256];
snprintf(error, sizeof(error), "Duplicate global variable binder: %s", name);
parse_error(parser, error);
}
parser->global_vars[idx].var = var_term;
} else {
push_lexical_binder(parser, name, var_term);
}
parse_term(parser, lam_node);
if (!starts_with_dollar(name)) {
pop_lexical_binder(parser);
}
store_term(parser, loc, LAM, 0, lam_node);
}
static void parse_term_app(Parser* parser, Val loc) {
expect(parser, "(", "for application");
parse_term(parser, loc);
skip(parser);
while (peek_char(parser) != ')') {
Val app_node = ic_alloc(parser->ic, 2);
move_term(parser, loc, app_node + 0);
parse_term(parser, app_node + 1);
store_term(parser, loc, APP, 0, app_node);
skip(parser);
}
expect(parser, ")", "after terms in application");
}
static void parse_term_sup(Parser* parser, Val loc) {
expect(parser, "&", "for superposition");
Lab label = parse_uint(parser) & LAB_MAX;
expect(parser, "{", "after label in superposition");
Val sup_node = ic_alloc(parser->ic, 2);
parse_term(parser, sup_node + 0);
expect(parser, ",", "between terms in superposition");
parse_term(parser, sup_node + 1);
expect(parser, "}", "after terms in superposition");
parser->ic->heap[loc] = ic_make_sup(label, sup_node);
}
static void parse_term_dup(Parser* parser, Val loc) {
expect(parser, "!&", "for duplication");
Lab label = parse_uint(parser) & LAB_MAX;
expect(parser, "{", "after label in duplication");
char x0[MAX_NAME_LEN];
char x1[MAX_NAME_LEN];
parse_name(parser, x0);
expect(parser, ",", "between names in duplication");
parse_name(parser, x1);
expect(parser, "}", "after names in duplication");
expect(parser, "=", "after names in duplication");
Val dup_node = ic_alloc(parser->ic, 1);
parse_term(parser, dup_node);
expect(parser, ";", "after value in duplication");
Term co0_term = ic_make_co0(label, dup_node);
Term co1_term = ic_make_co1(label, dup_node);
if (starts_with_dollar(x0)) {
size_t idx = find_or_add_global_var(parser, x0);
if (parser->global_vars[idx].var != NONE) {
char error[256];
snprintf(error, sizeof(error), "Duplicate global variable binder: %s", x0);
parse_error(parser, error);
}
parser->global_vars[idx].var = co0_term;
} else {
push_lexical_binder(parser, x0, co0_term);
}
if (starts_with_dollar(x1)) {
size_t idx = find_or_add_global_var(parser, x1);
if (parser->global_vars[idx].var != NONE) {
char error[256];
snprintf(error, sizeof(error), "Duplicate global variable binder: %s", x1);
parse_error(parser, error);
}
parser->global_vars[idx].var = co1_term;
} else {
push_lexical_binder(parser, x1, co1_term);
}
parse_term(parser, loc);
if (!starts_with_dollar(x1)) {
pop_lexical_binder(parser);
}
if (!starts_with_dollar(x0)) {
pop_lexical_binder(parser);
}
}
static void parse_term_era(Parser* parser, Val loc) {
expect(parser, "*", "for erasure");
store_term(parser, loc, ERA, 0, 0);
}
static void parse_term_num(Parser* parser, Val loc) {
Val value = parse_uint(parser);
store_term(parser, loc, NUM, 0, value);
}
static void parse_term_suc(Parser* parser, Val loc) {
expect(parser, "+", "for successor");
Val suc_node = ic_alloc(parser->ic, 1);
parse_term(parser, suc_node);
store_term(parser, loc, SUC, 0, suc_node);
}
static void parse_term_swi(Parser* parser, Val loc) {
expect(parser, "?", "for switch");
Val swi_node = ic_alloc(parser->ic, 3);
parse_term(parser, swi_node);
expect(parser, "{", "after condition in switch");
expect(parser, "0", "for zero case");
expect(parser, ":", "after '0'");
parse_term(parser, swi_node + 1);
expect(parser, ";", "after zero case");
expect(parser, "+", "for successor case");
expect(parser, ":", "after '+'");
parse_term(parser, swi_node + 2);
expect(parser, ";", "after successor case");
expect(parser, "}", "to close switch");
store_term(parser, loc, SWI, 0, swi_node);
}
static void parse_term_let(Parser* parser, Val loc) {
expect(parser, "!", "for let expression");
char name[MAX_NAME_LEN];
parse_name(parser, name);
expect(parser, "=", "after name in let expression");
Val app_node = ic_alloc(parser->ic, 2);
Val lam_node = ic_alloc(parser->ic, 1);
parse_term(parser, app_node + 1);
expect(parser, ";", "after value in let expression");
Term var_term = ic_make_term(VAR, 0, lam_node);
if (starts_with_dollar(name)) {
size_t idx = find_or_add_global_var(parser, name);
if (parser->global_vars[idx].var != NONE) {
char error[256];
snprintf(error, sizeof(error), "Duplicate global variable binder: %s", name);
parse_error(parser, error);
}
parser->global_vars[idx].var = var_term;
} else {
push_lexical_binder(parser, name, var_term);
}
parse_term(parser, lam_node);
if (!starts_with_dollar(name)) {
pop_lexical_binder(parser);
}
store_term(parser, app_node + 0, LAM, 0, lam_node);
store_term(parser, loc, APP, 0, app_node);
}
void parse_term(Parser* parser, Val loc) {
skip(parser);
if (parser->input[parser->pos] == '\0') {
parse_error(parser, "Unexpected end of input");
}
unsigned char c = (unsigned char)parser->input[parser->pos];
if (isalpha(c) || c == '_' || c == '$') {
parse_term_var(parser, loc);
} else if (isdigit(c)) {
parse_term_num(parser, loc);
} else if (c == '!') {
parser->pos++;
char next = peek_char(parser);
parser->pos--;
if (next == '&') {
parse_term_dup(parser, loc);
} else if (isalpha(next) || next == '_' || next == '$') {
parse_term_let(parser, loc);
} else {
parse_error(parser, "Expected '&' or name after '!' for duplication or let");
}
} else if (c == '&') {
parse_term_sup(parser, loc);
} else if (c == 0xCE && (unsigned char)parser->input[parser->pos + 1] == 0xBB) {
parse_term_lam(parser, loc);
} else if (c == '(') {
parse_term_app(parser, loc);
} else if (c == '*') {
parse_term_era(parser, loc);
} else if (c == '+') {
parse_term_suc(parser, loc);
} else if (c == '?') {
parse_term_swi(parser, loc);
} else {
char error_msg[100];
snprintf(error_msg, sizeof(error_msg), "Unexpected character: %c (code: %d)", c, (int)c);
parse_error(parser, error_msg);
}
}
Val parse_term_alloc(Parser* parser) {
Val loc = ic_alloc(parser->ic, 1);
parse_term(parser, loc);
return loc;
}
Term parse_string(IC* ic, const char* input) {
Parser parser;
init_parser(&parser, ic, input);
skip(&parser);
Val term_loc = parse_term_alloc(&parser);
resolve_global_vars(&parser);
return parser.ic->heap[term_loc];
}
Term parse_file(IC* ic, const char* filename) {
FILE* file = fopen(filename, "r");
if (!file) {
fprintf(stderr, "Error: Could not open file '%s'\n", filename);
exit(1);
}
fseek(file, 0, SEEK_END);
long size = ftell(file);
fseek(file, 0, SEEK_SET);
char* buffer = (char*)malloc(size + 1);
if (!buffer) {
fprintf(stderr, "Error: Memory allocation failed\n");
fclose(file);
exit(1);
}
size_t read_size = fread(buffer, 1, size, file);
fclose(file);
buffer[read_size] = '\0';
Term term = parse_string(ic, buffer);
free(buffer);
return term;
}
================================================
FILE: src/parse.h
================================================
#ifndef PARSE_H
#define PARSE_H
#include "ic.h"
#include <stdbool.h>
#include <stdint.h>
#define MAX_NAME_LEN 64
#define MAX_GLOBAL_VARS 1024
#define MAX_LEXICAL_VARS 1024
typedef struct {
char name[MAX_NAME_LEN];
Term var;
Val loc;
} Binder;
typedef struct {
IC* ic;
const char* input;
size_t pos;
size_t line;
size_t col;
Binder global_vars[MAX_GLOBAL_VARS];
size_t global_vars_count;
Binder lexical_vars[MAX_LEXICAL_VARS];
size_t lexical_vars_count;
} Parser;
void init_parser(Parser* parser, IC* ic, const char* input);
Term parse_string(IC* ic, const char* input);
Term parse_file(IC* ic, const char* filename);
#endif // PARSE_H
================================================
FILE: src/show.c
================================================
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdbool.h>
#include "ic.h"
#include "show.h"
// For backward compatibility with the showing code
#define DP0 100 // Just a value not used for any other tag
#define DP1 101 // Just a value not used for any other tag
// Helper functions for numeric operations
static Val get_num_val(Term term) {
if (TERM_TAG(term) == NUM) {
return TERM_VAL(term) & TERM_VAL_MASK;
} else {
return 0; // Default to 0 if not a number
}
}
// Maximum string length for term representation
#define MAX_STR_LEN 65536
// Structure to track variable names
typedef struct {
uint32_t count; // Number of variables encountered
Val* locations; // Array of variable locations
TermTag* types; // Array of variable types (VAR, DP0, DP1)
char** names; // Array of variable names
uint32_t capacity; // Capacity of the arrays
} VarNameTable;
// Structure to track duplication nodes
typedef struct {
Val* locations; // Array of duplication locations
Lab* labels; // Array of duplication labels
uint32_t count; // Number of duplications
uint32_t capacity; // Capacity of the array
} DupTable;
// Initialize variable name table
void init_var_table(VarNameTable* table) {
table->count = 0;
table->capacity = 64;
table->locations = (Val*)malloc(table->capacity * sizeof(Val));
table->types = (TermTag*)malloc(table->capacity * sizeof(TermTag));
table->names = (char**)malloc(table->capacity * sizeof(char*));
}
// Free variable name table
void free_var_table(VarNameTable* table) {
for (uint32_t i = 0; i < table->count; i++) {
free(table->names[i]);
}
free(table->locations);
free(table->types);
free(table->names);
}
// Initialize duplication table
void init_dup_table(DupTable* table) {
table->count = 0;
table->capacity = 64;
table->locations = (Val*)malloc(table->capacity * sizeof(Val));
table->labels = (Lab*)malloc(table->capacity * sizeof(Lab));
}
// Free duplication table
void free_dup_table(DupTable* table) {
free(table->locations);
free(table->labels);
}
// Convert an index to an alphabetic variable name (a, b, c, ..., z, aa, ab, ...)
char* index_to_var_name(uint32_t index) {
char* name = (char*)malloc(16);
if (index < 26) {
// a-z
sprintf(name, "%c", 'a' + index);
} else {
// aa, ab, ac, ...
uint32_t first = (index - 26) / 26;
uint32_t second = (index - 26) % 26;
sprintf(name, "%c%c", 'a' + first, 'a' + second);
}
return name;
}
// Add a variable to the table and return its name
char* add_variable(VarNameTable* table, Val location, TermTag type) {
// Check if we need to expand the table
if (table->count >= table->capacity) {
table->capacity *= 2;
table->locations = (Val*)realloc(table->locations, table->capacity * sizeof(Val));
table->types = (TermTag*)realloc(table->types, table->capacity * sizeof(TermTag));
table->names = (char**)realloc(table->names, table->capacity * sizeof(char*));
}
// For compatibility, we only store the basic types (VAR, DP0, DP1) in the table
TermTag basicType = type;
if (IS_DP0(type)) {
basicType = DP0;
} else if (IS_DP1(type)) {
basicType = DP1;
}
// Check if the variable is already in the table
for (uint32_t i = 0; i < table->count; i++) {
if (table->locations[i] == location && table->types[i] == basicType) {
return table->names[i];
}
}
// Add the new variable
table->locations[table->count] = location;
table->types[table->count] = basicType;
// Generate a name for the variable based on its type
char* name;
if (basicType == VAR) {
name = index_to_var_name(table->count);
} else if (basicType == DP0) {
name = (char*)malloc(16);
sprintf(name, "a%u", table->count);
} else if (basicType == DP1) {
name = (char*)malloc(16);
sprintf(name, "b%u", table->count);
}
table->names[table->count] = name;
table->count++;
return name;
}
// Get a variable name from the table
char* get_var_name(VarNameTable* table, Val location, TermTag type) {
// Convert to basic type for lookup
TermTag basicType = type;
if (IS_DP0(type)) {
basicType = DP0;
} else if (IS_DP1(type)) {
basicType = DP1;
}
for (uint32_t i = 0; i < table->count; i++) {
if (table->locations[i] == location && table->types[i] == basicType) {
return table->names[i];
}
}
return "?"; // Unknown variable
}
// Forward declarations
void assign_var_ids(IC* ic, Term term, VarNameTable* var_table, DupTable* dup_table);
void stringify_term(IC* ic, Term term, VarNameTable* var_table, char* buffer, int* pos, int max_len, const char* prefix);
void stringify_duplications(IC* ic, DupTable* dup_table, VarNameTable* var_table, char* buffer, int* pos, int max_len, const char* prefix);
// Register a duplication in the table
bool register_duplication(DupTable* table, Val location, Lab label) {
for (uint32_t i = 0; i < table->count; i++) {
if (table->locations[i] == location) {
if (table->labels[i] != label) {
fprintf(stderr, "Label mismatch for duplication\n");
exit(1);
}
return false;
}
}
if (table->count >= table->capacity) {
table->capacity *= 2;
table->locations = (Val*)realloc(table->locations, table->capacity * sizeof(Val));
table->labels = (Lab*)realloc(table->labels, table->capacity * sizeof(Lab));
}
table->locations[table->count] = location;
table->labels[table->count] = label;
table->count++;
return true;
}
// Assign IDs to variables and register duplications
void assign_var_ids(IC* ic, Term term, VarNameTable* var_table, DupTable* dup_table) {
TermTag tag = TERM_TAG(term);
Val val = TERM_VAL(term);
Lab lab = TERM_LAB(term);
if (tag == VAR) {
Val loc = val;
Term subst = ic->heap[loc];
if (TERM_SUB(subst)) {
assign_var_ids(ic, ic_clear_sub(subst), var_table, dup_table);
}
// For VAR, nothing else to do
} else if (IS_DUP(tag)) {
Val loc = val;
Term subst = ic->heap[loc];
if (TERM_SUB(subst)) {
assign_var_ids(ic, ic_clear_sub(subst), var_table, dup_table);
} else {
if (register_duplication(dup_table, loc, lab)) {
assign_var_ids(ic, subst, var_table, dup_table);
}
}
} else if (tag == LAM) {
Val lam_loc = val;
add_variable(var_table, lam_loc, VAR);
assign_var_ids(ic, ic->heap[lam_loc], var_table, dup_table);
} else if (tag == APP) {
Val app_loc = val;
assign_var_ids(ic, ic->heap[app_loc], var_table, dup_table);
assign_var_ids(ic, ic->heap[app_loc + 1], var_table, dup_table);
} else if (tag == ERA) {
// ERA terms don't have children, so nothing to do
} else if (IS_SUP(tag)) {
Val sup_loc = val;
assign_var_ids(ic, ic->heap[sup_loc], var_table, dup_table);
assign_var_ids(ic, ic->heap[sup_loc + 1], var_table, dup_table);
} else if (tag == NUM) {
// NUM has no variables to assign
} else if (tag == SUC) {
Val suc_loc = val;
assign_var_ids(ic, ic->heap[suc_loc], var_table, dup_table);
} else if (tag == SWI) {
Val swi_loc = val;
assign_var_ids(ic, ic->heap[swi_loc], var_table, dup_table); // Number
assign_var_ids(ic, ic->heap[swi_loc + 1], var_table, dup_table); // Zero branch
assign_var_ids(ic, ic->heap[swi_loc + 2], var_table, dup_table); // Successor branch
} else {
// Unknown tag, so nothing to do
}
}
// Stringify duplications
void stringify_duplications(IC* ic, DupTable* dup_table, VarNameTable* var_table, char* buffer, int* pos, int max_len, const char* prefix) {
// First, add all duplication variables
for (uint32_t i = 0; i < dup_table->count; i++) {
Val dup_loc = dup_table->locations[i];
add_variable(var_table, dup_loc, DP0);
add_variable(var_table, dup_loc, DP1);
}
// Then, stringify each duplication
for (uint32_t i = 0; i < dup_table->count; i++) {
Val dup_loc = dup_table->locations[i];
Lab lab = dup_table->labels[i];
Term val_term = ic->heap[dup_loc];
// Get variable names
char* var0 = get_var_name(var_table, dup_loc, DP0);
char* var1 = get_var_name(var_table, dup_loc, DP1);
// Add duplication header with optional prefix
if (prefix) {
*pos += snprintf(buffer + *pos, max_len - *pos, "! &%u{%s%s,%s%s} = ", lab, prefix, var0, prefix, var1);
} else {
*pos += snprintf(buffer + *pos, max_len - *pos, "! &%u{%s,%s} = ", lab, var0, var1);
}
// Add the value
stringify_term(ic, val_term, var_table, buffer, pos, max_len, prefix);
// Add separator
*pos += snprintf(buffer + *pos, max_len - *pos, ";\n");
}
}
// Stringify a term
void stringify_term(IC* ic, Term term, VarNameTable* var_table, char* buffer, int* pos, int max_len, const char* prefix) {
TermTag tag = TERM_TAG(term);
Val val = TERM_VAL(term);
Lab lab = TERM_LAB(term);
if (tag == VAR) {
Val loc = val;
Term subst = ic->heap[loc];
if (TERM_SUB(subst)) {
stringify_term(ic, ic_clear_sub(subst), var_table, buffer, pos, max_len, prefix);
} else {
char* name = get_var_name(var_table, loc, VAR);
if (prefix) {
*pos += snprintf(buffer + *pos, max_len - *pos, "%s%s", prefix, name);
} else {
*pos += snprintf(buffer + *pos, max_len - *pos, "%s", name);
}
}
} else if (IS_DUP(tag)) {
TermTag co_type = IS_DP0(tag) ? DP0 : DP1;
Val loc = val;
Term subst = ic->heap[loc];
if (TERM_SUB(subst)) {
stringify_term(ic, ic_clear_sub(subst), var_table, buffer, pos, max_len, prefix);
} else {
char* name = get_var_name(var_table, loc, co_type);
if (prefix) {
*pos += snprintf(buffer + *pos, max_len - *pos, "%s%s", prefix, name);
} else {
*pos += snprintf(buffer + *pos, max_len - *pos, "%s", name);
}
}
} else if (tag == LAM) {
Val lam_loc = val;
char* var_name = get_var_name(var_table, lam_loc, VAR);
if (prefix) {
*pos += snprintf(buffer + *pos, max_len - *pos, "λ%s%s.", prefix, var_name);
} else {
*pos += snprintf(buffer + *pos, max_len - *pos, "λ%s.", var_name);
}
stringify_term(ic, ic->heap[lam_loc], var_table, buffer, pos, max_len, prefix);
} else if (tag == APP) {
*pos += snprintf(buffer + *pos, max_len - *pos, "(");
stringify_term(ic, ic->heap[val], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, " ");
stringify_term(ic, ic->heap[val + 1], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, ")");
} else if (tag == ERA) {
*pos += snprintf(buffer + *pos, max_len - *pos, "*");
} else if (IS_SUP(tag)) {
*pos += snprintf(buffer + *pos, max_len - *pos, "&%u{", lab);
stringify_term(ic, ic->heap[val], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, ",");
stringify_term(ic, ic->heap[val + 1], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, "}");
} else if (tag == NUM) {
*pos += snprintf(buffer + *pos, max_len - *pos, "%u", val & TERM_VAL_MASK);
} else if (tag == SUC) {
*pos += snprintf(buffer + *pos, max_len - *pos, "+");
stringify_term(ic, ic->heap[val], var_table, buffer, pos, max_len, prefix);
} else if (tag == SWI) {
*pos += snprintf(buffer + *pos, max_len - *pos, "?");
stringify_term(ic, ic->heap[val], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, "{0:");
stringify_term(ic, ic->heap[val + 1], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, ";+:");
stringify_term(ic, ic->heap[val + 2], var_table, buffer, pos, max_len, prefix);
*pos += snprintf(buffer + *pos, max_len - *pos, ";}");
} else {
*pos += snprintf(buffer + *pos, max_len - *pos, "<?unknown term>");
}
}
// Convert a term to its string representation with optional namespace prefix
static char* term_to_string_internal(IC* ic, Term term, const char* prefix) {
// Initialize tables
VarNameTable var_table;
DupTable dup_table;
init_var_table(&var_table);
init_dup_table(&dup_table);
// Assign IDs to variables and register duplications
assign_var_ids(ic, term, &var_table, &dup_table);
// Allocate buffer for the string representation
char* buffer = (char*)malloc(MAX_STR_LEN);
int pos = 0;
// First stringify all duplications
stringify_duplications(ic, &dup_table, &var_table, buffer, &pos, MAX_STR_LEN, prefix);
// Then stringify the main term
stringify_term(ic, term, &var_table, buffer, &pos, MAX_STR_LEN, prefix);
// Free tables
free_var_table(&var_table);
free_dup_table(&dup_table);
return buffer;
}
// Convert a term to its string representation
char* term_to_string(IC* ic, Term term) {
return term_to_string_internal(ic, term, NULL);
}
// Convert a term to its string representation with a prefix for variable names
char* term_to_string_namespaced(IC* ic, Term term, const char* prefix) {
return term_to_string_internal(ic, term, prefix);
}
// Display a term to the specified output stream
void show_term(FILE* stream, IC* ic, Term term) {
char* str = term_to_string(ic, term);
fprintf(stream, "%s", str);
free(str);
}
// Display a term to the specified output stream with a prefix for variable names
void show_term_namespaced(FILE* stream, IC* ic, Term term, const char* prefix) {
char* str = term_to_string_namespaced(ic, term, prefix);
fprintf(stream, "%s", str);
free(str);
}
================================================
FILE: src/show.h
================================================
//./../InteractionCalculus.md//
//./show.c//
#ifndef SHOW_H
#define SHOW_H
#include <stdio.h>
#include "ic.h"
// Convert a term to its string representation
// The returned string is dynamically allocated and must be freed by the caller
char* term_to_string(IC* ic, Term term);
// Convert a term to its string representation with a prefix for variable names
// The returned string is dynamically allocated and must be freed by the caller
char* term_to_string_namespaced(IC* ic, Term term, const char* prefix);
// Display a term to the specified output stream
void show_term(FILE* stream, IC* ic, Term term);
// Display a term to the specified output stream with a prefix for variable names
void show_term_namespaced(FILE* stream, IC* ic, Term term, const char* prefix);
#endif // SHOW_H
gitextract_yzn1vp8o/
├── .gitignore
├── CLAUDE.md
├── Makefile
├── README.md
├── examples/
│ ├── test_0.ic
│ ├── test_1.ic
│ ├── test_2.ic
│ ├── test_3.ic
│ ├── test_4.ic
│ └── test_5.ic
├── haskell/
│ ├── main.hs
│ ├── main_debug.hs
│ └── modern_version.hs
└── src/
├── collapse.c
├── collapse.h
├── ic.c
├── ic.h
├── ic.metal
├── ic_metal.mm
├── main.c
├── parse.c
├── parse.h
├── show.c
└── show.h
SYMBOL INDEX (114 symbols across 7 files)
FILE: src/collapse.c
function Term (line 19) | static inline Term ic_era_lam(IC* ic, Term lam, Term era) {
function Term (line 34) | static inline Term ic_era_app(IC* ic, Term app, Term era) {
function Term (line 45) | static inline Term ic_sup_lam(IC* ic, Term lam, Term sup) {
function Term (line 86) | static inline Term ic_sup_app(IC* ic, Term app, Term sup) {
function Term (line 127) | static inline Term ic_sup_sup_x(IC* ic, Term outer_sup, Term inner_sup) {
function Term (line 169) | static inline Term ic_sup_sup_y(IC* ic, Term outer_sup, Term inner_sup) {
function Term (line 212) | static inline Term ic_dup_var(IC* ic, Term dup, Term var) {
function Term (line 226) | static inline Term ic_dup_app(IC* ic, Term dup, Term app) {
function Term (line 279) | static inline Term ic_sup_swi_z(IC* ic, Term swi, Term sup) {
function Term (line 327) | static inline Term ic_sup_swi_s(IC* ic, Term swi, Term sup) {
function Term (line 374) | Term ic_collapse_sups(IC* ic, Term term) {
function Term (line 445) | Term ic_collapse_dups(IC* ic, Term term) {
FILE: src/ic.c
function IC (line 11) | inline IC* ic_new(Val heap_size, Val stack_size) {
function IC (line 36) | inline IC* ic_default_new() {
function ic_free (line 42) | inline void ic_free(IC* ic) {
function Val (line 56) | inline Val ic_alloc(IC* ic, Val n) {
function Term (line 70) | inline Term ic_make_term(TermTag tag, Lab lab, Val val) {
function Term (line 77) | inline Term ic_make_sub(Term term) {
function Term (line 84) | inline Term ic_clear_sub(Term term) {
function Term (line 92) | inline Term ic_make_sup(Lab lab, Val val) {
function Term (line 100) | inline Term ic_make_co0(Lab lab, Val val) {
function Term (line 108) | inline Term ic_make_co1(Lab lab, Val val) {
function Term (line 114) | inline Term ic_make_era() {
function Term (line 121) | inline Term ic_make_num(Val val) {
function Term (line 128) | inline Term ic_make_suc(Val val) {
function Term (line 135) | inline Term ic_make_swi(Val val) {
function ic_is_era (line 142) | inline bool ic_is_era(Term term) {
function Val (line 147) | inline Val ic_lam(IC* ic, Term bod) {
function Val (line 154) | inline Val ic_app(IC* ic, Term fun, Term arg) {
function Val (line 162) | inline Val ic_sup(IC* ic, Term lft, Term rgt) {
function Val (line 170) | inline Val ic_dup(IC* ic, Term val) {
function Val (line 177) | inline Val ic_suc(IC* ic, Term num) {
function Val (line 184) | inline Val ic_swi(IC* ic, Term num, Term ifz, Term ifs) {
function Term (line 200) | inline Term ic_app_lam(IC* ic, Term app, Term lam) {
function Term (line 218) | inline Term ic_app_era(IC* ic, Term app, Term era) {
function Term (line 227) | inline Term ic_app_sup(IC* ic, Term app, Term sup) {
function Term (line 270) | inline Term ic_dup_era(IC* ic, Term dup, Term era) {
function Term (line 295) | inline Term ic_dup_lam(IC* ic, Term dup, Term lam) {
function Term (line 352) | inline Term ic_dup_sup(IC* ic, Term dup, Term sup) {
function Term (line 414) | inline Term ic_suc_num(IC* ic, Term suc, Term num) {
function Term (line 423) | inline Term ic_suc_era(IC* ic, Term suc, Term era) {
function Term (line 431) | inline Term ic_suc_sup(IC* ic, Term suc, Term sup) {
function Term (line 455) | inline Term ic_swi_num(IC* ic, Term swi, Term num) {
function Term (line 479) | inline Term ic_swi_era(IC* ic, Term swi, Term era) {
function Term (line 489) | inline Term ic_swi_sup(IC* ic, Term swi, Term sup) {
function Term (line 531) | inline Term ic_dup_num(IC* ic, Term dup, Term num) {
function Term (line 554) | inline Term ic_whnf(IC* ic, Term term) {
function Term (line 691) | inline Term ic_normal(IC* ic, Term term) {
FILE: src/ic.h
type TermTag (line 35) | typedef enum {
type Term (line 49) | typedef uint64_t Term;
type Val (line 50) | typedef uint64_t Val;
type Lab (line 51) | typedef uint16_t Lab;
type TermTag (line 87) | typedef enum {
type Term (line 123) | typedef uint32_t Term;
type Val (line 124) | typedef uint32_t Val;
type Lab (line 125) | typedef uint8_t Lab;
type IC (line 167) | typedef struct {
FILE: src/main.c
function ic_metal_available (line 19) | static inline int ic_metal_available() {
function Term (line 23) | static inline Term ic_normal_metal(IC* ic, Term term) {
function Term (line 40) | static Term normalize_term(IC* ic, Term term, int use_gpu, int use_colla...
function process_term (line 70) | static void process_term(IC* ic, Term term, int use_gpu, int use_collaps...
function benchmark_term (line 117) | static void benchmark_term(IC* ic, Term term, int use_gpu, int use_colla...
function test (line 189) | static void test(IC* ic, int use_gpu, int use_collapse, int thread_count) {
function print_usage (line 196) | static void print_usage(void) {
function main (line 211) | int main(int argc, char* argv[]) {
FILE: src/parse.c
function starts_with_dollar (line 18) | static bool starts_with_dollar(const char* name) {
function find_or_add_global_var (line 22) | static size_t find_or_add_global_var(Parser* parser, const char* name) {
function push_lexical_binder (line 40) | static void push_lexical_binder(Parser* parser, const char* name, Term t...
function pop_lexical_binder (line 52) | static void pop_lexical_binder(Parser* parser) {
function Binder (line 58) | static Binder* find_lexical_binder(Parser* parser, const char* name) {
function resolve_global_vars (line 67) | static void resolve_global_vars(Parser* parser) {
function move_term (line 81) | static void move_term(Parser* parser, Val from_loc, Val to_loc) {
function consume (line 96) | bool consume(Parser* parser, const char* str) {
function parse_error (line 108) | void parse_error(Parser* parser, const char* message) {
function expect (line 120) | bool expect(Parser* parser, const char* token, const char* error_context) {
function init_parser (line 130) | void init_parser(Parser* parser, IC* ic, const char* input) {
function parse_name (line 140) | static void parse_name(Parser* parser, char* name) {
function next_char (line 156) | char next_char(Parser* parser) {
function peek_char (line 167) | char peek_char(Parser* parser) {
function peek_is (line 171) | bool peek_is(Parser* parser, char c) {
function store_term (line 175) | void store_term(Parser* parser, Val loc, TermTag tag, Lab lab, Val value) {
function Val (line 179) | Val parse_uint(Parser* parser) {
function skip (line 192) | void skip(Parser* parser) {
function check_utf8 (line 212) | bool check_utf8(Parser* parser, uint8_t b1, uint8_t b2) {
function consume_utf8 (line 217) | void consume_utf8(Parser* parser, int bytes) {
function parse_term_var (line 224) | static void parse_term_var(Parser* parser, Val loc) {
function parse_term_lam (line 256) | static void parse_term_lam(Parser* parser, Val loc) {
function parse_term_app (line 285) | static void parse_term_app(Parser* parser, Val loc) {
function parse_term_sup (line 299) | static void parse_term_sup(Parser* parser, Val loc) {
function parse_term_dup (line 311) | static void parse_term_dup(Parser* parser, Val loc) {
function parse_term_era (line 358) | static void parse_term_era(Parser* parser, Val loc) {
function parse_term_num (line 363) | static void parse_term_num(Parser* parser, Val loc) {
function parse_term_suc (line 368) | static void parse_term_suc(Parser* parser, Val loc) {
function parse_term_swi (line 375) | static void parse_term_swi(Parser* parser, Val loc) {
function parse_term_let (line 392) | static void parse_term_let(Parser* parser, Val loc) {
function parse_term (line 421) | void parse_term(Parser* parser, Val loc) {
function Val (line 461) | Val parse_term_alloc(Parser* parser) {
function Term (line 467) | Term parse_string(IC* ic, const char* input) {
function Term (line 476) | Term parse_file(IC* ic, const char* filename) {
FILE: src/parse.h
type Binder (line 12) | typedef struct {
type Parser (line 18) | typedef struct {
FILE: src/show.c
function Val (line 13) | static Val get_num_val(Term term) {
type VarNameTable (line 25) | typedef struct {
type DupTable (line 34) | typedef struct {
function init_var_table (line 42) | void init_var_table(VarNameTable* table) {
function free_var_table (line 51) | void free_var_table(VarNameTable* table) {
function init_dup_table (line 61) | void init_dup_table(DupTable* table) {
function free_dup_table (line 69) | void free_dup_table(DupTable* table) {
function register_duplication (line 159) | bool register_duplication(DupTable* table, Val location, Lab label) {
function assign_var_ids (line 181) | void assign_var_ids(IC* ic, Term term, VarNameTable* var_table, DupTable...
function stringify_duplications (line 242) | void stringify_duplications(IC* ic, DupTable* dup_table, VarNameTable* v...
function stringify_term (line 276) | void stringify_term(IC* ic, Term term, VarNameTable* var_table, char* bu...
function show_term (line 397) | void show_term(FILE* stream, IC* ic, Term term) {
function show_term_namespaced (line 404) | void show_term_namespaced(FILE* stream, IC* ic, Term term, const char* p...
Condensed preview — 24 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (206K chars).
[
{
"path": ".gitignore",
"chars": 444,
"preview": ".tmp/\nbin/\nobj/\n\n# Compiled Object files\n*.o\n*.ko\n*.obj\n*.elf\n\n# Compiled Dynamic libraries\n*.so\n*.dylib\n*.dll\n\n# Compil"
},
{
"path": "CLAUDE.md",
"chars": 604,
"preview": "# IC Project Guide\n\n## Important Files\n- `README.md` - Project Spec (ALWAYS READ IT)\n- `src/main.c` - Program entry poin"
},
{
"path": "Makefile",
"chars": 2896,
"preview": "CC = gcc\nCFLAGS = -w -std=c99 -O3 -march=native -mtune=native -flto\n\n# Check for 64-bit mode flag\nifdef USE_64BIT\n CFLA"
},
{
"path": "README.md",
"chars": 20564,
"preview": "# Interaction Calculus\n\nThe Interaction Calculus is a minimal term rewriting system inspired by the\nLambda Calculus (λC)"
},
{
"path": "examples/test_0.ic",
"chars": 653,
"preview": "!P19 = λf.\n !&0{f0,f1} = f;\n !&0{f0,f1} = λx.(f0 (f1 x));\n !&0{f0,f1} = λx.(f0 (f1 x));\n !&0{f0,f1} = λx.(f0 (f1 x))"
},
{
"path": "examples/test_1.ic",
"chars": 265,
"preview": "λf. λx. !&0{f0,f1}=f; (f0 (f1 x))\n\n//&2{&1{&0{λa.a,λb.b},&0{λc.c,λd.d}},&1{&0{λe.e,λf.f},&0{λg.g,λh.h}}}\n\n\n// "
},
{
"path": "examples/test_2.ic",
"chars": 553,
"preview": "λt.(t λ$x.$y λ$y.$x)\n\n// λx. !&0{x0,x1}=x; &0{(x0 λa.λb.a),(x1 λt.λf.f)}\n\n// !&0{x0,x1}=&0{k0,k1}; &0{λk0.(x0 λa.a),λk1."
},
{
"path": "examples/test_3.ic",
"chars": 1039,
"preview": "λf.λx.(f (f (f x)))\n\n//! &0{a3,b4} = x0; (λx0.λx1.((x1 x0) b4) λx2.x2)\n\n//!P19 = λf. \n //!&0{f00x,f00y} = f; \n //!&0"
},
{
"path": "examples/test_4.ic",
"chars": 323,
"preview": "!Y = λf. !&1{f0,f1}=λx.!&1{x0,x1}=x;(f (x0 x1)); (f0 f1);\n\n!true = λt. λf. t;\n!false = λt. λf. f;\n\n!not = λb. (b false t"
},
{
"path": "examples/test_5.ic",
"chars": 401,
"preview": "// Test switch on superposition - test SUP-SWI-S interaction\nλx.?x{0:0;+:&0{1,2};}\n\n//!&0{a2,b3} = 0;\n//&0{λa.?a{0:a2;+:"
},
{
"path": "haskell/main.hs",
"chars": 14136,
"preview": "-- Welcome to the Interaction Calculus Haskell reference implementation! :D This\n-- file is very simple, and great for l"
},
{
"path": "haskell/main_debug.hs",
"chars": 16309,
"preview": "{- README.md -}\n\n{-# LANGUAGE MultilineStrings #-}\n\n-- This is like main.hs, but includes a step-by-step debugger.\n\nimpo"
},
{
"path": "haskell/modern_version.hs",
"chars": 27529,
"preview": "-- Calculus of Interactions\n-- ========================\n-- CoI is a term rewrite system for the following grammar:\n-- \n-"
},
{
"path": "src/collapse.c",
"chars": 14142,
"preview": "//./../IC.md//\n//./ic.h//\n//./collapse.h//\n\n// This is a WIP\n\n#include \"ic.h\"\n#include \"collapse.h\"\n#include \"show.h\"\n\n/"
},
{
"path": "src/collapse.h",
"chars": 844,
"preview": "//./collapse.c//\n\n#ifndef IC_COLLAPSE_H\n#define IC_COLLAPSE_H\n\n#include \"ic.h\"\n\nstatic inline Term ic_era_lam(IC* ic, Te"
},
{
"path": "src/ic.c",
"chars": 19056,
"preview": "#include \"ic.h\"\n\n// -----------------------------------------------------------------------------\n// Memory Management F"
},
{
"path": "src/ic.h",
"chars": 9964,
"preview": "#ifndef IC_H\n#define IC_H\n\n// -----------------------------------------------------------------------------\n// Interacti"
},
{
"path": "src/ic.metal",
"chars": 16681,
"preview": "#include <metal_stdlib>\n#include <metal_atomic>\nusing namespace metal;\n\n/**\n * Interaction Calculus (IC) - Metal impleme"
},
{
"path": "src/ic_metal.mm",
"chars": 11441,
"preview": "#import <Foundation/Foundation.h>\n#import <Metal/Metal.h>\n#include \"ic.h\"\n\n/**\n * Interaction Calculus (IC) - Metal Obje"
},
{
"path": "src/main.c",
"chars": 8692,
"preview": "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <time.h>\n#include <sys/time.h>\n#include \"ic.h\"\n#incl"
},
{
"path": "src/parse.c",
"chars": 14825,
"preview": "// parse.c\n#include \"parse.h\"\n#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <ctype.h>\n\n// Forward "
},
{
"path": "src/parse.h",
"chars": 667,
"preview": "#ifndef PARSE_H\n#define PARSE_H\n\n#include \"ic.h\"\n#include <stdbool.h>\n#include <stdint.h>\n\n#define MAX_NAME_LEN 64\n#defi"
},
{
"path": "src/show.c",
"chars": 13625,
"preview": "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <stdbool.h>\n#include \"ic.h\"\n#include \"show.h\"\n\n// Fo"
},
{
"path": "src/show.h",
"chars": 794,
"preview": "//./../InteractionCalculus.md//\n//./show.c//\n\n#ifndef SHOW_H\n#define SHOW_H\n\n#include <stdio.h>\n#include \"ic.h\"\n\n// Conv"
}
]
About this extraction
This page contains the full source code of the VictorTaelin/Symmetric-Interaction-Calculus GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 24 files (191.8 KB), approximately 62.0k tokens, and a symbol index with 114 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.