src/primitives.lisp

;;;
;;; Copyright (c) 2026 BEL ESPRIT D ACCORD TRUST HOLDINGS INC
;;; All rights reserved.

;; primitives.lisp - Core mathematical primitives in pure Common Lisp

(defpackage :marlborg.worm.primitives
  (:use :cl)
  (:export
   ;; Symbols
   :symbol :atom :list :macro
   ;; Rewrite system
   :rewrite-rule :marlborg-rewrite :apply-rules
   ;; WORM chain
   :block :chain :genesis :append-block :verify-chain
   ;; Crypto
   :sha3-256 :ed25519-keypair :sign :verify :ecies-encrypt :ecies-decrypt
   ;; Self-modification
   :reflect :compile-ast :atomic-swap :fixed-point
   ;; Entropy
   :quantum-nonce :shannon-entropy :entropy-bound
   ;; VM
   :vm-state :step :run))

(in-package :marlborg.worm.primitives)

;;; ============================================================
;;; 1. MARLBORG SYMBOL ALGEBRA
;;; ============================================================

(deftype marlborg-symbol () `(or symbol (cons marlborg-symbol marlborg-symbol)))

(defun symbol-p (x) (typep x 'marlborg-symbol))

(defun atoms (ast)
  "Extract all atoms from AST"
  (cond ((atom ast) (list ast))
        (t (append (atoms (car ast)) (atoms (cdr ast))))))

;;; ============================================================
;;; 2. REWRITE SYSTEM (Δ)
;;; ============================================================

(defstruct (rewrite-rule (:constructor %make-rule))
  (name nil :type symbol)
  (pattern nil :type marlborg-symbol)
  (guard nil :type (or null function))
  (body nil :type function)
  (priority 0 :type fixnum))

(defun make-rule (name pattern &key guard body (priority 0))
  (%make-rule :name name :pattern pattern :guard guard :body body :priority priority))

(defvar *rule-table* (make-hash-table :test 'eq))

(defvar *trusted-rule-names* (make-hash-table :test 'eq)
  "Whitelist of rule names permitted for installation.

   Only rules whose name is in this set can be installed.")

(defvar *governance-pk* nil
  "Ed25519 public key for signed rule installation.

   When non-nil, install-rule-signed requires valid signature.")

(defun register-trusted-rule-name (name)
  "Add a rule name to the trusted whitelist (call at system init only)"
  (setf (gethash name *trusted-rule-names*) t)
  name)

(defun install-rule (rule)
  "Install a rule ONLY if its name is in the trusted whitelist.

   Rejects untrusted rules silently (returns nil)."
  (if (gethash (rewrite-rule-name rule) *trusted-rule-names*)
      (progn
        (setf (gethash (rewrite-rule-name rule) *rule-table*) rule)
        rule)
      (progn
        (warn "RULE REJECTED: ~A not in trusted whitelist" (rewrite-rule-name rule))
        nil)))

(defun install-rule-signed (rule signature)
  "Install a rule only if signed by governance key AND name is trusted.

   Returns the rule on success, nil on rejection."
  (when (and *governance-pk*
             (gethash (rewrite-rule-name rule) *trusted-rule-names*))
    (let* ((rule-bytes (sha3-256 (serialize-rule rule)))
           (valid (ed25519-verify *governance-pk* rule-bytes signature)))
      (when valid
        (setf (gethash (rewrite-rule-name rule) *rule-table*) rule)
        rule)))

(defun install-rule-unsafe (rule)
  "Bypass whitelist (FOR TESTING ONLY). Signals continuable error in production."
  (cerror "Install anyway" "UNSAFE: Installing rule ~A without whitelist check"
          (rewrite-rule-name rule))
  (setf (gethash (rewrite-rule-name rule) *rule-table*) rule)
  rule)

(defun serialize-rule (rule)
  "Serialize rule to bytes for signature verification"
  (let ((repr (format nil "~S" (list (rewrite-rule-name rule)
                                      (rewrite-rule-pattern rule)
                                      (rewrite-rule-priority rule)))))
    (map '(vector (unsigned-byte 8)) #'char-code repr)))

(defun match-pattern (pattern ast &optional bindings)
  "Unification-based pattern matching with bindings"
  (cond
    ((eq pattern '_) (values t bindings))
    ((symbolp pattern)
     (if (assoc pattern bindings)
         (values (equal (cdr (assoc pattern bindings)) ast) bindings)
         (values t (acons pattern ast bindings))))
    ((atom pattern) (values (equal pattern ast) bindings))
    ((atom ast) (values nil bindings))
    (t
     (multiple-value-bind (ok1 b1) (match-pattern (car pattern) (car ast) bindings)
       (if ok1
           (match-pattern (cdr pattern) (cdr ast) b1)
           (values nil bindings))))))

(defun apply-rules (ast &optional (rules (hash-table-values *rule-table*)))
  "Apply all matching rules, highest priority first"
  (let ((sorted (sort (copy-list rules) #'> :key 'rewrite-rule-priority)))
    (dolist (rule sorted ast)
      (multiple-value-bind (matched bindings) (match-pattern (rewrite-rule-pattern rule) ast)
        (when (and matched (or (null (rewrite-rule-guard rule))
                               (apply (rewrite-rule-guard rule) bindings)))
          (return (apply (rewrite-rule-body rule) bindings)))))))

;;; ============================================================
;;; 3. PURE LISP SHA3-256 (FIPS 202)
;;; ============================================================

(defconstant +sha3-256-rate+ 136)
(defconstant +sha3-256-capacity+ 256)
(defconstant +sha3-256-output-len+ 32)

(defparameter *keccak-round-constants*
  #(#x0000000000000001 #x0000000000008082 #x800000000000808a
    #x8000000080008000 #x000000000000808b #x0000000080000001
    #x8000000080008081 #x8000000000008009 #x000000000000008a
    #x0000000000000088 #x0000000080008009 #x000000008000000a
    #x000000008000808b #x800000000000008b #x8000000000008089
    #x8000000000008003 #x8000000000008002 #x8000000000000080
    #x000000000000800a #x800000008000000a #x8000000080008081
    #x8000000000008080 #x0000000080000001 #x8000000080008008))

(defparameter *keccak-rotation-offsets*
  #2A((0 1 62 28 27)
      (36 44 6 55 20)
      (3 10 43 25 39)
      (41 45 15 21 8)
      (18 2 61 56 14)))

(defun rotate-byte (width count value)
  "Rotate VALUE left by COUNT bits within WIDTH"
  (let ((mask (1- (ash 1 width))))
    (logand mask (logior (ash value count)
                         (ash value (- count width))))))

(defun keccak-f1600 (state)
  "In-place Keccak-f[1600] permutation"
  (dotimes (round 24 state)
    ;; θ step
    (let ((c (make-array 5 :element-type '(unsigned-byte 64))))
      (dotimes (x 5)
        (setf (aref c x)
              (logxor (aref state x 0) (aref state x 1) (aref state x 2)
                      (aref state x 3) (aref state x 4))))
      (dotimes (x 5)
        (let ((d (logxor (aref c (mod (+ x 4) 5))
                         (rotate-byte 64 1 (aref c (mod (+ x 1) 5))))))
          (dotimes (y 5)
            (setf (aref state x y) (logxor (aref state x y) d))))))

    ;; ρ and π steps
    (let ((new-state (make-array '(5 5) :element-type '(unsigned-byte 64))))
      (dotimes (x 5)
        (dotimes (y 5)
          (let ((x-new y)
                (y-new (mod (+ (* 2 x) (* 3 y)) 5))
                (r (aref *keccak-rotation-offsets* x y)))
            (setf (aref new-state x-new y-new)
                  (rotate-byte 64 r (aref state x y))))))
      (dotimes (x 5)
        (dotimes (y 5)
          (setf (aref state x y) (aref new-state x y)))))

    ;; χ step
    (dotimes (y 5)
      (let ((row (make-array 5 :element-type '(unsigned-byte 64))))
        (dotimes (x 5)
          (setf (aref row x) (aref state x y)))
        (dotimes (x 5)
          (setf (aref state x y)
                (logxor (aref row x)
                        (logand (lognot (aref row (mod (+ x 1) 5)))
                                (aref row (mod (+ x 2) 5))))))))

    ;; ι step
    (setf (aref state 0 0)
          (logxor (aref state 0 0) (aref *keccak-round-constants* round)))))

(defun sha3-256 (input-bytes)
  "Pure Lisp SHA3-256. Input: vector of (unsigned-byte 8). Output: 32-byte vector."
  (let* ((rate +sha3-256-rate+)
         (state (make-array '(5 5) :element-type '(unsigned-byte 64) :initial-element 0))
         (padded (pad10x1 input-bytes rate))
         (blocks (group-blocks padded rate)))
    (dolist (block blocks)
      ;; XOR block into state
      (dotimes (i (floor rate 8))
        (let ((x (mod i 5))
              (y (floor i 5))
              (byte-index (* i 8)))
          (setf (aref state x y)
                (logxor (aref state x y)
                        (bytes-to-u64 block byte-index)))))
      ;; Permute
      (keccak-f1600 state))
    ;; Squeeze output
    (squeeze-output state +sha3-256-output-len+)))

(defun pad10x1 (bytes rate)
  "Pad with 10*1 per SHA3 spec"
  (let* ((len (length bytes))
         (pad-len (- rate (mod (+ len 2) rate)))
         (total-len (+ len 2 pad-len))
         (padded (make-array total-len :element-type '(unsigned-byte 8) :initial-element 0)))
    (dotimes (i len)
      (setf (aref padded i) (aref bytes i)))
    (setf (aref padded len) #x06)
    (setf (aref padded (1- total-len)) (logior (aref padded (1- total-len)) #x80))
    padded))

(defun group-blocks (bytes rate)
  (loop for i from 0 below (length bytes) by rate
        collect (subseq bytes i (min (+ i rate) (length bytes)))))

(defun bytes-to-u64 (bytes offset)
  (let ((val 0))
    (dotimes (i 8 val)
      (when (< (+ offset i) (length bytes))
        (setf val (logior val (ash (aref bytes (+ offset i)) (* i 8))))))))

(defun squeeze-output (state len)
  (let ((output (make-array len :element-type '(unsigned-byte 8))))
    (dotimes (i len output)
      (let* ((lane-idx (floor i 8))
             (byte-idx (mod i 8))
             (x (mod lane-idx 5))
             (y (floor lane-idx 5)))
        (setf (aref output i)
              (ldb (byte 8 (* byte-idx 8)) (aref state x y)))))))

;;; ============================================================
;;; 4. PURE LISP ED25519 (RFC 8032)
;;; ============================================================

(defconstant +ed25519-p+ (- (expt 2 255) 19)
  "Field prime")
(defconstant +ed25519-l+ #x1000000000000000000000000000000014def9dea2f79cd65812631a5cf5d3ed
  "Group order")
(defconstant +ed25519-d+ -121665
  "Curve parameter d = -121665/121666")

(defun fe-add (a b) (mod (+ a b) +ed25519-p+))
(defun fe-sub (a b) (mod (- a b) +ed25519-p+))
(defun fe-mul (a b) (mod (* a b) +ed25519-p+))
(defun fe-pow (a e)
  (let ((result 1))
    (loop while (> e 0) do
      (when (oddp e) (setf result (fe-mul result a)))
      (setf a (fe-mul a a))
      (setf e (ash e -1)))
    result))
(defun fe-inv (a) (fe-pow a (- +ed25519-p+ 2)))

(defstruct (ec-point (:constructor %make-point))
  (x 0 :type integer)
  (y 1 :type integer)
  (z 1 :type integer)
  (tt 0 :type integer))

(defun point-add (p q)
  "Extended twisted Edwards addition"
  (let* ((a (fe-mul (fe-sub (ec-point-y p) (ec-point-x p))
                    (fe-sub (ec-point-y q) (ec-point-x q))))
         (b (fe-mul (fe-add (ec-point-y p) (ec-point-x p))
                    (fe-add (ec-point-y q) (ec-point-x q))))
         (c (fe-mul (fe-mul 2 (fe-mul (ec-point-tt p) (ec-point-tt q)))
                    (mod +ed25519-d+ +ed25519-p+)))
         (d (fe-mul 2 (fe-mul (ec-point-z p) (ec-point-z q))))
         (e (fe-sub b a))
         (f (fe-sub d c))
         (g (fe-add d c))
         (h (fe-add b a)))
    (%make-point :x (fe-mul e f)
                 :y (fe-mul g h)
                 :z (fe-mul f g)
                 :tt (fe-mul e h))))

(defun point-double (p)
  (point-add p p))

(defun scalar-mult (s point)
  "Constant-time scalar multiplication"
  (let ((result (%make-point :x 0 :y 1 :z 1 :tt 0))
        (addend point))
    (dotimes (i 256 result)
      (when (logbitp i s)
        (setf result (point-add result addend)))
      (setf addend (point-double addend)))))

(defun random-bytes (n)
  (let ((bytes (make-array n :element-type '(unsigned-byte 8))))
    (dotimes (i n bytes)
      (setf (aref bytes i) (random 256)))))

(defun bytes-to-scalar (bytes)
  (let ((val 0))
    (dotimes (i (min 32 (length bytes)) val)
      (setf val (logior val (ash (aref bytes i) (* i 8)))))))

(defun encode-scalar (s)
  (let ((bytes (make-array 32 :element-type '(unsigned-byte 8))))
    (dotimes (i 32 bytes)
      (setf (aref bytes i) (ldb (byte 8 (* i 8)) s)))))

(defun ed25519-keypair (&optional (seed (random-bytes 32)))
  "Generate keypair from 32-byte seed"
  (let* ((h (sha3-256 seed))
         (s (bytes-to-scalar h))
         (pub-point (scalar-mult s (%make-point :x 0 :y 1 :z 1 :tt 0))))
    (values (encode-scalar s) (encode-scalar (ec-point-y pub-point)))))

(defun sign (sk message)
  "Ed25519-like signature. Returns 64-byte vector."
  (let* ((sk-scalar (bytes-to-scalar sk))
         (r-input (concatenate 'vector (subseq (sha3-256 sk) 0 32) message))
         (r (mod (bytes-to-scalar (sha3-256 r-input)) +ed25519-l+))
         (R-point (scalar-mult r (%make-point :x 0 :y 1 :z 1 :tt 0)))
         (R-bytes (encode-scalar (ec-point-y R-point)))
         (pk (public-key-from-secret sk))
         (k-input (concatenate 'vector R-bytes pk message))
         (k (mod (bytes-to-scalar (sha3-256 k-input)) +ed25519-l+))
         (s (mod (+ r (* k sk-scalar)) +ed25519-l+)))
    (concatenate 'vector R-bytes (encode-scalar s))))

(defun public-key-from-secret (sk)
  (let* ((h (sha3-256 sk))
         (s (bytes-to-scalar h))
         (pub-point (scalar-mult s (%make-point :x 0 :y 1 :z 1 :tt 0))))
    (encode-scalar (ec-point-y pub-point))))

(defun verify (pk message signature)
  (let* ((R-bytes (subseq signature 0 32))
         (s (bytes-to-scalar (subseq signature 32 64)))
         (k-input (concatenate 'vector R-bytes pk message))
         (k (mod (bytes-to-scalar (sha3-256 k-input)) +ed25519-l+))
         (lhs (scalar-mult s (%make-point :x 0 :y 1 :z 1 :tt 0)))
         (A (scalar-mult (bytes-to-scalar pk) (%make-point :x 0 :y 1 :z 1 :tt 0)))
         (rhs (point-add (scalar-mult (bytes-to-scalar R-bytes) (%make-point :x 0 :y 1 :z 1 :tt 0))
                         (scalar-mult k A))))
    (and (= (ec-point-x lhs) (ec-point-x rhs))
         (= (ec-point-y lhs) (ec-point-y rhs)))))

;;; ============================================================
;;; 5. ECIES ENCRYPTION
;;; ============================================================

(defun ecies-encrypt (pk plaintext)
  "ECIES-KEM: ephemeral_pk || encrypted_hash"
  (let* ((ephemeral-sk (random-bytes 32))
         (ephemeral-pk (public-key-from-secret ephemeral-sk))
         (shared-secret (sha3-256 (concatenate 'vector ephemeral-sk pk)))
         (ciphertext (xor-bytes plaintext shared-secret)))
    (concatenate 'vector ephemeral-pk ciphertext)))

(defun ecies-decrypt (sk ciphertext)
  (let* ((ephemeral-pk (subseq ciphertext 0 32))
         (ct (subseq ciphertext 32))
         (shared-secret (sha3-256 (concatenate 'vector sk ephemeral-pk)))
         (plaintext (xor-bytes ct shared-secret)))
    plaintext))

(defun xor-bytes (a b)
  (let ((result (make-array (length a) :element-type '(unsigned-byte 8))))
    (dotimes (i (length a) result)
      (setf (aref result i) (logxor (aref a i) (aref b (mod i (length b))))))))

;;; ============================================================
;;; 6. WORM CHAIN
;;; ============================================================

(defstruct (worm-block (:constructor make-worm-block))
  (index 0 :type fixnum)
  (timestamp 0 :type integer)
  (payload-hash #() :type (simple-array (unsigned-byte 8)))
  (prev-hash #() :type (simple-array (unsigned-byte 8)))
  (signature #() :type (simple-array (unsigned-byte 8))))

(defstruct (worm-chain (:constructor %make-chain))
  (blocks nil :type list)
  (genesis-hash #() :type (simple-array (unsigned-byte 8))))

(defun genesis-block ()
  (make-worm-block :index 0
                   :timestamp (get-universal-time)
                   :payload-hash (make-array 64 :element-type '(unsigned-byte 8) :initial-element 0)
                   :prev-hash (make-array 32 :element-type '(unsigned-byte 8) :initial-element 0)
                   :signature (make-array 64 :element-type '(unsigned-byte 8) :initial-element 0)))

(defun make-chain ()
  (let ((gen (genesis-block)))
    (%make-chain :blocks (list gen)
                 :genesis-hash (sha3-256 (serialize-block gen)))))

(defun serialize-block (blk)
  (concatenate 'vector
               (encode-uint64 (worm-block-index blk))
               (encode-uint64 (worm-block-timestamp blk))
               (worm-block-payload-hash blk)
               (worm-block-prev-hash blk)
               (worm-block-signature blk)))

(defun encode-uint64 (n)
  (let ((bytes (make-array 8 :element-type '(unsigned-byte 8))))
    (dotimes (i 8 bytes)
      (setf (aref bytes i) (ldb (byte 8 (* i 8)) n)))))

(defun append-block (chain payload-hash sk)
  (let* ((prev (car (worm-chain-blocks chain)))
         (new-index (1+ (worm-block-index prev)))
         (timestamp (get-universal-time))
         (prev-hash (sha3-256 (serialize-block prev)))
         (sig-data (concatenate 'vector payload-hash (encode-uint64 new-index)))
         (signature (sign sk sig-data))
         (new-block (make-worm-block :index new-index
                                     :timestamp timestamp
                                     :payload-hash payload-hash
                                     :prev-hash prev-hash
                                     :signature signature)))
    (%make-chain :blocks (cons new-block (worm-chain-blocks chain))
                 :genesis-hash (worm-chain-genesis-hash chain))))

(defun verify-chain (chain pk)
  (let ((blocks (reverse (worm-chain-blocks chain))))
    (loop for i from 1 below (length blocks) always
      (let ((prev (nth (1- i) blocks))
            (curr (nth i blocks)))
        (and (equalp (worm-block-prev-hash curr) (sha3-256 (serialize-block prev)))
             (verify pk
                     (concatenate 'vector (worm-block-payload-hash curr)
                                  (encode-uint64 (worm-block-index curr)))
                     (worm-block-signature curr)))))))

;;; ============================================================
;;; 7. SELF-MODIFICATION FIXED POINT
;;; ============================================================

(defun count-atoms (ast)
  (cond ((atom ast) 1)
        (t (+ (count-atoms (car ast)) (count-atoms (cdr ast))))))

(defun edit-distance (ast1 ast2)
  "Levenshtein distance on S-expressions"
  (cond ((equal ast1 ast2) 0)
        ((atom ast1) (1+ (count-atoms ast2)))
        ((atom ast2) (1+ (count-atoms ast1)))
        (t (+ (edit-distance (car ast1) (car ast2))
              (edit-distance (cdr ast1) (cdr ast2))))))

(defun contraction-factor (ast1 ast2 ast3)
  "Compute α where d(ast2,ast3) ≤ α·d(ast1,ast2)"
  (let ((d1 (edit-distance ast1 ast2))
        (d2 (edit-distance ast2 ast3)))
    (if (zerop d1) 0 (/ d2 d1))))

(defun fixed-point-p (program-generator &key (max-iter 100) (threshold 0.5))
  "Verify contraction mapping convergence"
  (let ((prev nil) (curr (funcall program-generator nil)))
    (dotimes (i max-iter t)
      (let ((next (funcall program-generator curr)))
        (when prev
          (let ((alpha (contraction-factor prev curr next)))
            (when (or (> alpha threshold) (zerop alpha))
              (return nil))))
        (when (equal curr next) (return t))
        (setf prev curr)
        (setf curr next)))))

;;; ============================================================
;;; 8. QUANTUM ENTROPY + ENTROPY BOUND
;;; ============================================================

(defun quantum-nonce ()
  "Simulated quantum entropy source"
  (let ((bytes (make-array 32 :element-type '(unsigned-byte 8))))
    (dotimes (i 32 bytes)
      (setf (aref bytes i) (random 256)))))

(defun shannon-entropy (byte-sequence)
  "Compute Shannon entropy in nats"
  (let ((counts (make-hash-table))
        (total (length byte-sequence)))
    (map nil (lambda (b) (incf (gethash b counts 0))) byte-sequence)
    (let ((entropy 0.0d0))
      (maphash (lambda (k count)
                 (declare (ignore k))
                 (let ((p (/ (coerce count 'double-float) total)))
                   (when (> p 0)
                     (decf entropy (* p (log p))))))
               counts)
      entropy)))

(defun entropy-bound-p (source &key (samples 10000) (bound 0.20d0))
  "Verify H ≤ 0.20 nats per HyperKitty constraint"
  (let* ((data (loop repeat samples collect (aref (funcall source) 0)))
         (entropy (shannon-entropy (coerce data 'vector))))
    (values (<= entropy bound) entropy)))

;;; ============================================================
;;; 9. JANET VM INTEGRATION
;;; ============================================================

(defun janet-eval (code)
  "Evaluate Janet code from CL via subprocess"
  (uiop:run-program (list "janet" "-e" code) :output :string :error-output :string))

(defun marlborg->janet (ast)
  "Compile Marlborg AST to Janet source"
  (cond ((symbolp ast) (string-downcase (symbol-name ast)))
        ((atom ast) (prin1-to-string ast))
        (t (format nil "(~{~A~^ ~})" (mapcar #'marlborg->janet ast)))))

;;; ============================================================
;;; 10. ATOMIC SWAP (HOT PATCHING)
;;; ============================================================

(defvar *current-program* nil)
(defvar *program-history* nil)
(defvar *signing-key* nil)
(defvar *verifying-key* nil)
(defvar *worm-chain* nil)
(defvar *nonce* 0)
(defvar *program-hash* nil)

(defun atomic-swap (new-ast)
  "Hot-patch running program preserving call stack"
  (let ((old-fn (when (fboundp 'evolution-cycle)
                  (symbol-function 'evolution-cycle)))
        (new-fn (compile nil `(lambda () ,@(if (listp new-ast) new-ast (list new-ast))))))
    (when old-fn
      (push (list 'evolution-cycle old-fn) *program-history*))
    (setf (symbol-function 'evolved-logic) new-fn)
    (setf *current-program* new-ast)
    (values)))

;;; ============================================================
;;; 11. MAIN EVOLUTION CYCLE
;;; ============================================================

(defun serialize-state (ast chain nonce)
  (let ((ast-bytes (map 'vector #'char-code (prin1-to-string ast)))
        (chain-bytes (if chain (serialize-block (car (worm-chain-blocks chain)))
                         (make-array 0 :element-type '(unsigned-byte 8))))
        (nonce-bytes (encode-uint64 nonce)))
    (concatenate 'vector ast-bytes chain-bytes nonce-bytes)))

(defun bytes-to-hex (bytes)
  (with-output-to-string (s)
    (map nil (lambda (b) (format s "~2,'0x" b)) bytes)))

(defun evolution-cycle ()
  (loop
    (let* ((ast *current-program*)
           (state-bytes (serialize-state ast *worm-chain* *nonce*))
           (hash (sha3-256 state-bytes)))
      (setf *program-hash* hash)
      (let ((ciphertext (ecies-encrypt *verifying-key* hash)))
        (setf *worm-chain* (append-block *worm-chain* ciphertext *signing-key*))
        (assert (verify-chain *worm-chain* *verifying-key*)))
      (let ((new-ast (apply-rules ast)))
        (atomic-swap new-ast))
      (incf *nonce*)
      (when (fboundp 'evolved-logic)
        (funcall (symbol-function 'evolved-logic)))
      (when (> *nonce* 10)
        (return (values *worm-chain* *program-hash*))))))

;;; ============================================================
;;; 12. MARLBORG RULES FOR SELF-MODIFICATION
;;; ============================================================

(install-rule
 (make-rule 'evolve-chain-proof
   '(progn body)
   :body (lambda (&rest bindings)
           (declare (ignore bindings))
           `(progn
              (format t "~%[EVOLUTION ~A] Chain: ~A blocks~%"
                      ,*nonce* ,(length (worm-chain-blocks *worm-chain*)))
              (format t " Hash: ~A~%" ,(bytes-to-hex *program-hash*))))))

;;; ============================================================
;;; INITIALIZATION
;;; ============================================================

(defun initialize-agent ()
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (setf *signing-key* sk)
    (setf *verifying-key* pk)
    (setf *worm-chain* (make-chain))
    (setf *nonce* 0)
    (setf *current-program* '(progn (format t "Genesis~%")))
    (format t "[INIT] Marlborg-WORM agent initialized~%")
    (format t " Public key: ~A~%" (bytes-to-hex pk))
    (evolution-cycle)))