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