rose-ash/lib/apl/transpile.sx

; APL transpile / AST evaluator
;
; Walks parsed AST nodes and evaluates against the runtime.
; Entry points:
;   apl-eval-ast    : node × env → value
;   apl-eval-stmts  : stmt-list × env → value (handles guards, locals, ⍺← default)
;   apl-call-dfn    : dfn-ast × ⍺ × ⍵ → value   (dyadic)
;   apl-call-dfn-m  : dfn-ast × ⍵ → value       (monadic)
;
; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega",
; the dfn-ast itself under "nabla" (for ∇ recursion),
; user names under their literal name.

(define
  apl-monadic-fn
  (fn
    (g)
    (cond
      ((= g "+") apl-plus-m)
      ((= g "-") apl-neg-m)
      ((= g "×") apl-signum)
      ((= g "÷") apl-recip)
      ((= g "⌈") apl-ceil)
      ((= g "⌊") apl-floor)
      ((= g "⍳") apl-iota)
      ((= g "|") apl-abs)
      ((= g "*") apl-exp)
      ((= g "⍟") apl-ln)
      ((= g "!") apl-fact)
      ((= g "○") apl-pi-times)
      ((= g "~") apl-not)
      ((= g "≢") apl-tally)
      ((= g "⍴") apl-shape)
      ((= g "≡") apl-depth)
      ((= g "⊂") apl-enclose)
      ((= g "⊃") apl-disclose)
      ((= g ",") apl-ravel)
      ((= g "⌽") apl-reverse)
      ((= g "⊖") apl-reverse-first)
      ((= g "⍋") apl-grade-up)
      ((= g "⍒") apl-grade-down)
      (else (error "no monadic fn for glyph")))))

(define
  apl-dyadic-fn
  (fn
    (g)
    (cond
      ((= g "+") apl-add)
      ((= g "-") apl-sub)
      ((= g "×") apl-mul)
      ((= g "÷") apl-div)
      ((= g "⌈") apl-max)
      ((= g "⌊") apl-min)
      ((= g "*") apl-pow)
      ((= g "⍟") apl-log)
      ((= g "|") apl-mod)
      ((= g "!") apl-binomial)
      ((= g "○") apl-trig)
      ((= g "<") apl-lt)
      ((= g "≤") apl-le)
      ((= g "=") apl-eq)
      ((= g "≥") apl-ge)
      ((= g ">") apl-gt)
      ((= g "≠") apl-ne)
      ((= g "∧") apl-and)
      ((= g "∨") apl-or)
      ((= g "⍱") apl-nor)
      ((= g "⍲") apl-nand)
      ((= g ",") apl-catenate)
      ((= g "⍪") apl-catenate-first)
      ((= g "⍴") apl-reshape)
      ((= g "↑") apl-take)
      ((= g "↓") apl-drop)
      ((= g "⌷") apl-squad)
      ((= g "⌽") apl-rotate)
      ((= g "⊖") apl-rotate-first)
      ((= g "∊") apl-member)
      ((= g "⍳") apl-index-of)
      ((= g "~") apl-without)
      (else (error "no dyadic fn for glyph")))))

(define
  apl-truthy?
  (fn
    (v)
    (let
      ((rv (get v :ravel)))
      (if (and (= (len rv) 1) (= (first rv) 0)) false true))))

(define
  apl-eval-ast
  (fn
    (node env)
    (let
      ((tag (first node)))
      (cond
        ((= tag :num) (apl-scalar (nth node 1)))
        ((= tag :vec)
          (let
            ((items (rest node)))
            (let
              ((vals (map (fn (n) (apl-eval-ast n env)) items)))
              (make-array
                (list (len vals))
                (map (fn (v) (first (get v :ravel))) vals)))))
        ((= tag :name)
          (let
            ((nm (nth node 1)))
            (cond
              ((= nm "⍺") (get env "alpha"))
              ((= nm "⍵") (get env "omega"))
              (else (get env nm)))))
        ((= tag :monad)
          (let
            ((fn-node (nth node 1)) (arg (nth node 2)))
            (let
              ((g (nth fn-node 1)))
              (if
                (= g "∇")
                (apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
                ((apl-monadic-fn g) (apl-eval-ast arg env))))))
        ((= tag :dyad)
          (let
            ((fn-node (nth node 1))
              (lhs (nth node 2))
              (rhs (nth node 3)))
            (let
              ((g (nth fn-node 1)))
              (if
                (= g "∇")
                (apl-call-dfn
                  (get env "nabla")
                  (apl-eval-ast lhs env)
                  (apl-eval-ast rhs env))
                ((apl-dyadic-fn g)
                  (apl-eval-ast lhs env)
                  (apl-eval-ast rhs env))))))
        ((= tag :program) (apl-eval-stmts (rest node) env))
        ((= tag :dfn) node)
        (else (error (list "apl-eval-ast: unknown node tag" tag node)))))))

(define
  apl-eval-stmts
  (fn
    (stmts env)
    (if
      (= (len stmts) 0)
      nil
      (let
        ((stmt (first stmts)) (more (rest stmts)))
        (let
          ((tag (first stmt)))
          (cond
            ((= tag :guard)
              (let
                ((cond-val (apl-eval-ast (nth stmt 1) env)))
                (if
                  (apl-truthy? cond-val)
                  (apl-eval-ast (nth stmt 2) env)
                  (apl-eval-stmts more env))))
            ((and (= tag :assign) (= (nth stmt 1) "⍺"))
              (if
                (get env "alpha")
                (apl-eval-stmts more env)
                (let
                  ((v (apl-eval-ast (nth stmt 2) env)))
                  (apl-eval-stmts more (assoc env "alpha" v)))))
            ((= tag :assign)
              (let
                ((v (apl-eval-ast (nth stmt 2) env)))
                (apl-eval-stmts more (assoc env (nth stmt 1) v))))
            ((= (len more) 0) (apl-eval-ast stmt env))
            (else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env)))))))))

(define
  apl-call-dfn
  (fn
    (dfn-ast alpha omega)
    (let
      ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha}))
      (apl-eval-stmts stmts env))))

(define
  apl-call-dfn-m
  (fn
    (dfn-ast omega)
    (let
      ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
      (apl-eval-stmts stmts env))))

(define
  apl-tradfn-eval-block
  (fn
    (stmts env)
    (if
      (= (len stmts) 0)
      env
      (let
        ((stmt (first stmts)))
        (apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env))))))

(define
  apl-tradfn-eval-while
  (fn
    (cond-expr body env)
    (let
      ((cond-val (apl-eval-ast cond-expr env)))
      (if
        (apl-truthy? cond-val)
        (apl-tradfn-eval-while
          cond-expr
          body
          (apl-tradfn-eval-block body env))
        env))))

(define
  apl-tradfn-eval-for
  (fn
    (var-name items body env)
    (if
      (= (len items) 0)
      env
      (let
        ((env-with-var (assoc env var-name (apl-scalar (first items)))))
        (apl-tradfn-eval-for
          var-name
          (rest items)
          body
          (apl-tradfn-eval-block body env-with-var))))))

(define
  apl-tradfn-eval-select
  (fn
    (val cases default-block env)
    (if
      (= (len cases) 0)
      (apl-tradfn-eval-block default-block env)
      (let
        ((c (first cases)))
        (let
          ((case-val (apl-eval-ast (first c) env)))
          (if
            (= (first (get val :ravel)) (first (get case-val :ravel)))
            (apl-tradfn-eval-block (rest c) env)
            (apl-tradfn-eval-select val (rest cases) default-block env)))))))

(define
  apl-tradfn-eval-stmt
  (fn
    (stmt env)
    (let
      ((tag (first stmt)))
      (cond
        ((= tag :assign)
          (assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env)))
        ((= tag :if)
          (let
            ((cond-val (apl-eval-ast (nth stmt 1) env)))
            (if
              (apl-truthy? cond-val)
              (apl-tradfn-eval-block (nth stmt 2) env)
              (apl-tradfn-eval-block (nth stmt 3) env))))
        ((= tag :while)
          (apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env))
        ((= tag :for)
          (let
            ((iter-val (apl-eval-ast (nth stmt 2) env)))
            (apl-tradfn-eval-for
              (nth stmt 1)
              (get iter-val :ravel)
              (nth stmt 3)
              env)))
        ((= tag :select)
          (let
            ((val (apl-eval-ast (nth stmt 1) env)))
            (apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env)))
        (else (begin (apl-eval-ast stmt env) env))))))

(define
  apl-tradfn-loop
  (fn
    (stmts line env result-name)
    (cond
      ((= line 0) (get env result-name))
      ((> line (len stmts)) (get env result-name))
      (else
        (let
          ((stmt (nth stmts (- line 1))))
          (let
            ((tag (first stmt)))
            (cond
              ((= tag :branch)
                (let
                  ((target (apl-eval-ast (nth stmt 1) env)))
                  (let
                    ((target-num (first (get target :ravel))))
                    (apl-tradfn-loop stmts target-num env result-name))))
              (else
                (apl-tradfn-loop
                  stmts
                  (+ line 1)
                  (apl-tradfn-eval-stmt stmt env)
                  result-name)))))))))

(define
  apl-call-tradfn
  (fn
    (tradfn alpha omega)
    (let
      ((stmts (get tradfn :stmts))
        (result-name (get tradfn :result))
        (alpha-name (get tradfn :alpha))
        (omega-name (get tradfn :omega)))
      (let
        ((env-a (if alpha-name (assoc {} alpha-name alpha) {})))
        (let
          ((env-ao (if omega-name (assoc env-a omega-name omega) env-a)))
          (apl-tradfn-loop stmts 1 env-ao result-name))))))

(define
  apl-ast-mentions-list?
  (fn
    (lst target)
    (if
      (= (len lst) 0)
      false
      (if
        (apl-ast-mentions? (first lst) target)
        true
        (apl-ast-mentions-list? (rest lst) target)))))

(define
  apl-ast-mentions?
  (fn
    (node target)
    (cond
      ((not (list? node)) false)
      ((= (len node) 0) false)
      ((and (= (first node) :name) (= (nth node 1) target)) true)
      (else (apl-ast-mentions-list? (rest node) target)))))

(define
  apl-dfn-valence
  (fn
    (dfn-ast)
    (let
      ((body (rest dfn-ast)))
      (cond
        ((apl-ast-mentions-list? body "⍺") :dyadic)
        ((apl-ast-mentions-list? body "⍵") :monadic)
        (else :niladic)))))

(define
  apl-tradfn-valence
  (fn
    (tradfn)
    (cond
      ((get tradfn :alpha) :dyadic)
      ((get tradfn :omega) :monadic)
      (else :niladic))))

(define
  apl-call
  (fn
    (f alpha omega)
    (cond
      ((and (list? f) (> (len f) 0) (= (first f) :dfn))
        (if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega)))
      ((dict? f) (apl-call-tradfn f alpha omega))
      (else (error "apl-call: not a function")))))