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 #include #include #include #include // 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 #include 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 #import #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 device; id commandQueue; id library; id normalizeFunction; id normalizePipeline; id heapBuffer; id stackBuffer; id heapPosBuffer; id stackPosBuffer; id interactionsBuffer; id heapSizeBuffer; id 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 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 commandBuffer = [metalContext.commandQueue commandBuffer]; id 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 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 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 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 #include #include #include #include #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 [arguments] [options]\n\n"); printf("Commands:\n"); printf(" run - Parse and normalize a IC file on CPU\n"); printf(" run-gpu - Parse and normalize a IC file on GPU (Metal)\n"); printf(" eval - Parse and normalize a IC expression on CPU\n"); printf(" eval-gpu - Parse and normalize a IC expression on GPU (Metal)\n"); printf(" bench - Benchmark normalization of a IC file on CPU\n"); printf(" bench-gpu - 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 #include #include #include // 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 #include #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 #include #include #include #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, ""); } } // 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 #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