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-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))))
              ((= tag :assign)
                (let
                  ((v (apl-eval-ast (nth stmt 2) env)))
                  (apl-tradfn-loop
                    stmts
                    (+ line 1)
                    (assoc env (nth stmt 1) v)
                    result-name)))
              (else
                (begin
                  (apl-eval-ast stmt env)
                  (apl-tradfn-loop stmts (+ line 1) 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))))))