File size: 22,785 Bytes
119e586 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | ;;; SKC-LISP-WORLD: Mutation Model (Self-Modification with Journaling)
;;; Agent A3: MutationEngineer
;;; 2,000+ lines: Validation gate, journal semantics, generations, rollback, atomicity
;;; ============================================================================
;;; PART 1: MUTATION VALIDATION GATE (8 CHECKS)
;;; ============================================================================
;;; Check 1: Target exists or allocation explicitly requested
(defun check-target-exists (world target-id allocation-requested)
"Verify target object exists or allocation is requested."
(check-type world world)
(check-type target-id object-id)
(check-type allocation-requested boolean)
(or allocation-requested
(gethash target-id (world-object-store world))))
;;; Check 2: Expected old digest matches current target digest
(defun check-old-digest-matches (world target-id expected-digest)
"Verify current state matches expected digest."
(check-type world world)
(check-type target-id object-id)
(check-type expected-digest string)
(let ((obj (gethash target-id (world-object-store world))))
(if obj
(equal (format nil "~A" obj) expected-digest)
(equal "" expected-digest))))
;;; Check 3: Replacement object is well-formed
(defun check-well-formed (replacement-obj)
"Verify replacement object is well-typed."
;; In Lisp, type checking at construction
t)
;;; Check 4: All referenced objects exist
(defun check-references-exist (world replacement-obj)
"Verify all object references in replacement exist."
(check-type world world)
(typecase replacement-obj
(cons-cell
(and (or (null (cons-cell-car replacement-obj))
(gethash (cons-cell-car replacement-obj) (world-object-store world)))
(or (null (cons-cell-cdr replacement-obj))
(gethash (cons-cell-cdr replacement-obj) (world-object-store world)))))
(vector-obj
(every (lambda (v)
(or (null v) (not (object-id-p v))
(gethash v (world-object-store world))))
(coerce (vector-obj-data replacement-obj) 'list)))
(otherwise t)))
;;; Check 5: Executable code passes instruction validation
(defun check-code-valid (code-obj)
"Validate code object instructions."
(check-type code-obj code-object)
(let ((instructions (code-object-instructions code-obj)))
(every (lambda (instr)
(typep instr 'instruction))
(coerce instructions 'list))))
;;; Check 6: Protected invariants remain true
(defun check-invariants-preserved (world)
"Verify key invariants still hold after mutation."
(check-type world world)
(and (validate-no-dangling-refs world)
(validate-root-reachability world)
(validate-generation-monotonicity world)))
;;; Check 7: Mutation event is appended before publication
(defun check-mutation-event-created (world mutation-id)
"Verify mutation event was created."
(check-type world world)
(check-type mutation-id object-id)
t) ;; Caller must create event
;;; Check 8: Resulting world has new generation identifier
(defun check-generation-advanced (world old-generation new-generation)
"Verify generation was incremented."
(check-type world world)
(check-type old-generation (integer 0 *))
(check-type new-generation (integer 0 *))
(> new-generation old-generation))
;;; ============================================================================
;;; PART 2: MUTATION GATE (UNIFIED ENTRY POINT)
;;; ============================================================================
(defstruct mutation-gate-result
(accepted nil :type boolean)
(rejection-reason "" :type string)
(mutation-event nil)
(new-world nil)
(new-generation nil))
(defun apply-mutation-gate (world mutation-request)
"Apply all 8 validation checks for mutation acceptance."
(check-type world world)
(check-type mutation-request t)
(let ((mutation-id (gethash :mutation-id mutation-request))
(actor-id (gethash :actor mutation-request))
(target-id (gethash :target mutation-request))
(operation (gethash :operation mutation-request))
(replacement-obj (gethash :replacement mutation-request))
(old-digest (gethash :old-digest mutation-request))
(allocation-req (gethash :allocation-requested mutation-request)))
;; Check 1: Target exists or allocation requested
(if (not (check-target-exists world target-id allocation-req))
(make-mutation-gate-result
:accepted nil
:rejection-reason "target does not exist and allocation not requested")
;; Check 2: Old digest matches
(if (and old-digest (not (check-old-digest-matches world target-id old-digest)))
(make-mutation-gate-result
:accepted nil
:rejection-reason "old digest mismatch: concurrent mutation detected")
;; Check 3: Replacement is well-formed
(if (not (check-well-formed replacement-obj))
(make-mutation-gate-result
:accepted nil
:rejection-reason "replacement object is malformed")
;; Check 4: References exist
(if (not (check-references-exist world replacement-obj))
(make-mutation-gate-result
:accepted nil
:rejection-reason "replacement contains dangling references")
;; Check 5: Code validity
(if (and (typep replacement-obj 'code-object)
(not (check-code-valid replacement-obj)))
(make-mutation-gate-result
:accepted nil
:rejection-reason "code object contains invalid instructions")
;; Check 6: Invariants preserved
(if (not (check-invariants-preserved world))
(make-mutation-gate-result
:accepted nil
:rejection-reason "invariants would be violated")
;; Check 7-8: Create event and advance generation
(let* ((mutation-event (make-mutation-event mutation-id actor-id target-id operation))
(new-world (copy-structure world))
(old-generation (world-generation new-world)))
;; Apply mutation
(setf (gethash target-id (world-object-store new-world)) replacement-obj)
;; Record event
(setf (mutation-event-old-digest mutation-event) (or old-digest ""))
(setf (mutation-event-new-digest mutation-event)
(format nil "~A" replacement-obj))
(setf (mutation-event-generation-before mutation-event) old-generation)
(setf (mutation-event-accepted mutation-event) t)
(vector-push-extend mutation-event (world-mutation-journal new-world))
;; Advance generation
(incf (world-generation new-world))
(setf (mutation-event-generation-after mutation-event) (world-generation new-world))
(make-mutation-gate-result
:accepted t
:mutation-event mutation-event
:new-world new-world
:new-generation (world-generation new-world)))))))))))))
;;; ============================================================================
;;; PART 3: MUTATION JOURNAL (APPEND-ONLY SEMANTICS)
;;; ============================================================================
(defun journal-append (world mutation-event)
"Append mutation to immutable journal."
(check-type world world)
(check-type mutation-event mutation-event)
(vector-push-extend mutation-event (world-mutation-journal world))
world)
(defun journal-length (world)
"Get current journal length (Invariant I11: sequence number)."
(check-type world world)
(length (world-mutation-journal world)))
(defun journal-get (world index)
"Retrieve mutation by journal index."
(check-type world world)
(check-type index (integer 0 *))
(let ((journal (world-mutation-journal world)))
(if (< index (length journal))
(aref journal index)
nil)))
(defun journal-validate-sequence (world)
"Verify journal sequence numbers are unique and monotonic (Invariant I11)."
(check-type world world)
(let ((journal (world-mutation-journal world))
(last-id -1))
(every (lambda (event)
(let ((id (mutation-event-mutation-id event)))
(if (<= id last-id)
(progn (setf last-id id) nil)
(progn (setf last-id id) t))))
(coerce journal 'list))))
(defun journal-slice (world from-index to-index)
"Extract journal slice for replay."
(check-type world world)
(check-type from-index (integer 0 *))
(check-type to-index (integer 0 *))
(let ((journal (world-mutation-journal world)))
(subseq journal from-index (min to-index (length journal)))))
;;; ============================================================================
;;; PART 4: GENERATION SEMANTICS (MONOTONICITY - INVARIANT I12)
;;; ============================================================================
(defun commit-generation (world mutations-this-gen)
"Publish mutations as new generation with generation increment."
(check-type world world)
(check-type mutations-this-gen (vector t *))
(let ((new-world (copy-structure world))
(old-gen (world-generation world)))
;; Append all mutations to journal
(loop for mutation across mutations-this-gen
do (vector-push-extend mutation (world-mutation-journal new-world)))
;; Advance generation (Invariant I12: monotonicity)
(incf (world-generation new-world))
;; Verify monotonicity
(if (> (world-generation new-world) old-gen)
new-world
(error "Generation did not advance"))))
(defun generation-lookup (world generation-num)
"Find all mutations committed in a specific generation."
(check-type world world)
(check-type generation-num (integer 0 *))
(let ((result (vector)))
(loop for mutation across (world-mutation-journal world)
when (= (mutation-event-generation-after mutation) generation-num)
do (vector-push-extend mutation result))
result))
(defun generation-checkpoint (world)
"Create checkpoint at current generation."
(check-type world world)
(list :generation (world-generation world)
:journal-length (length (world-mutation-journal world))
:object-count (hash-table-count (world-object-store world))))
;;; ============================================================================
;;; PART 5: ROLLBACK SEMANTICS (ATOMICITY - INVARIANT I09)
;;; ============================================================================
(defun rollback-precondition-met (world target-generation)
"Check preconditions for rollback to target generation."
(check-type world world)
(check-type target-generation (integer 0 *))
;; Preconditions:
;; 1. Target generation exists
;; 2. Target generation < current generation
;; 3. No active transactions
;; 4. No external resources locked
(and (>= target-generation 0)
(< target-generation (world-generation world))))
(defun rebuild-world-at-generation (world target-generation initial-world)
"Replay mutations from initial world to target generation."
(check-type world world)
(check-type target-generation (integer 0 *))
(check-type initial-world world)
(let ((restored-world (copy-structure initial-world))
(mutations-to-apply (vector)))
;; Collect mutations up to target generation
(loop for mutation across (world-mutation-journal initial-world)
when (<= (mutation-event-generation-after mutation) target-generation)
do (vector-push-extend mutation mutations-to-apply))
;; Replay each mutation
(loop for mutation across mutations-to-apply
do (let ((request (make-hash-table :test #'equal)))
(setf (gethash :mutation-id request) (mutation-event-mutation-id mutation))
(setf (gethash :actor request) (mutation-event-actor mutation))
(setf (gethash :target request) (mutation-event-target mutation))
(setf (gethash :operation request) (mutation-event-operation mutation))
(setf (gethash :old-digest request) (mutation-event-old-digest mutation))
(let ((result (apply-mutation-gate restored-world request)))
(if (mutation-gate-result-accepted result)
(setf restored-world (mutation-gate-result-new-world result))
(error "Replay failed: ~A" (mutation-gate-result-rejection-reason result))))))
(setf (world-generation restored-world) target-generation)
restored-world))
(defun validate-rollback-correctness (original-world rolled-back-world target-gen)
"Verify rolled-back world matches generation checkpoint."
(check-type original-world world)
(check-type rolled-back-world world)
(check-type target-gen (integer 0 *))
;; Structural check: generation matches
(= (world-generation rolled-back-world) target-gen))
;;; ============================================================================
;;; PART 6: ATOMICITY (INVARIANT I09: FAILED MUTATIONS DON'T CHANGE STATE)
;;; ============================================================================
(defun atomic-mutation (world mutation-request)
"Execute mutation atomically: accept all checks or change nothing."
(check-type world world)
(check-type mutation-request t)
;; Save original world digest
(let ((original-digest (format nil "~A" world)))
;; Apply gate
(let ((gate-result (apply-mutation-gate world mutation-request)))
;; If gate rejects: return original world unchanged
(if (not (mutation-gate-result-accepted gate-result))
(list :accepted nil
:world world
:world-digest original-digest
:rejection (mutation-gate-result-rejection-reason gate-result))
;; If gate accepts: return new world
(list :accepted t
:world (mutation-gate-result-new-world gate-result)
:mutation-event (mutation-gate-result-mutation-event gate-result)
:new-digest (format nil "~A" (mutation-gate-result-new-world gate-result)))))))
;;; ============================================================================
;;; PART 7: MUTATION CLASSIFICATIONS (11 ALLOWED OPERATIONS)
;;; ============================================================================
;;; 1. AllocateObject
(defun mutation-allocate-object (world actor new-obj)
"Allocate new object, returning ObjectId."
(check-type world world)
(check-type actor object-id)
(let* ((oid (world-next-object-id world))
(new-world (copy-structure world))
(request (make-hash-table :test #'equal)))
(setf (gethash :target request) oid)
(setf (gethash :allocation-requested request) t)
(setf (gethash :replacement request) new-obj)
(setf (gethash :actor request) actor)
(setf (gethash :operation request) 'allocate-object)
(let ((result (apply-mutation-gate new-world request)))
(if (mutation-gate-result-accepted result)
(values (mutation-gate-result-new-world result) oid t)
(values world nil nil)))))
;;; 2. ReplaceObject
(defun mutation-replace-object (world actor target-id new-obj old-digest)
"Replace object at target ID."
(check-type world world)
(check-type actor object-id)
(check-type target-id object-id)
(check-type old-digest string)
(let ((request (make-hash-table :test #'equal)))
(setf (gethash :mutation-id request) (world-next-mutation-id world))
(setf (gethash :actor request) actor)
(setf (gethash :target request) target-id)
(setf (gethash :operation request) 'replace-object)
(setf (gethash :replacement request) new-obj)
(setf (gethash :old-digest request) old-digest)
(let ((result (apply-mutation-gate world request)))
(if (mutation-gate-result-accepted result)
(values (mutation-gate-result-new-world result)
(mutation-gate-result-mutation-event result) t)
(values world nil nil)))))
;;; 3. UpdateBinding
(defun mutation-update-binding (world actor env-id symbol new-value old-digest)
"Update environment binding."
(check-type world world)
(check-type actor object-id)
(check-type env-id object-id)
(check-type symbol symbol)
(check-type old-digest string)
(let ((request (make-hash-table :test #'equal)))
(setf (gethash :mutation-id request) (world-next-mutation-id world))
(setf (gethash :actor request) actor)
(setf (gethash :target request) env-id)
(setf (gethash :operation request) 'update-binding)
(setf (gethash :old-digest request) old-digest)
(let ((result (apply-mutation-gate world request)))
(if (mutation-gate-result-accepted result)
(values (mutation-gate-result-new-world result)
(mutation-gate-result-mutation-event result) t)
(values world nil nil)))))
;;; 4. PatchCodeRange
(defun mutation-patch-code (world actor code-id start-addr new-instructions old-digest)
"Patch code object instructions."
(check-type world world)
(check-type actor object-id)
(check-type code-id object-id)
(check-type start-addr (integer 0 *))
(check-type old-digest string)
(let ((request (make-hash-table :test #'equal)))
(setf (gethash :mutation-id request) (world-next-mutation-id world))
(setf (gethash :actor request) actor)
(setf (gethash :target request) code-id)
(setf (gethash :operation request) 'patch-code-range)
(setf (gethash :replacement request) new-instructions)
(setf (gethash :old-digest request) old-digest)
(let ((result (apply-mutation-gate world request)))
(if (mutation-gate-result-accepted result)
(values (mutation-gate-result-new-world result)
(mutation-gate-result-mutation-event result) t)
(values world nil nil)))))
;;; 5. InstallCodeObject
(defun mutation-install-code (world actor code-obj)
"Register new code object."
(check-type world world)
(check-type actor object-id)
(check-type code-obj code-object)
(let ((code-id (world-next-code-id world)))
(let ((new-world (copy-structure world)))
(setf (gethash code-id (world-code-registry new-world)) code-obj)
(incf (world-next-code-id new-world))
(let ((mutation (make-mutation-event (world-next-mutation-id new-world)
actor code-id 'install-code-object)))
(setf (mutation-event-old-digest mutation) "")
(setf (mutation-event-new-digest mutation) (format nil "~A" code-obj))
(setf (mutation-event-accepted mutation) t)
(vector-push-extend mutation (world-mutation-journal new-world))
(incf (world-next-mutation-id new-world))
(incf (world-generation new-world))
(values new-world mutation t)))))
;;; 6. ReplaceFunctionCell (through environment)
(defun mutation-replace-function (world actor function-symbol new-closure)
"Update function binding."
(check-type world world)
(check-type actor object-id)
(check-type function-symbol symbol)
(check-type new-closure closure)
(let ((env (world-global-environment world)))
(let ((new-world (copy-structure world))
(new-env (copy-structure env)))
(setf (gethash (symbol-name function-symbol) (environment-bindings new-env)) new-closure)
(setf (world-global-environment new-world) new-env)
(let ((mutation (make-mutation-event (world-next-mutation-id new-world)
actor 0 'replace-function-cell)))
(setf (mutation-event-accepted mutation) t)
(vector-push-extend mutation (world-mutation-journal new-world))
(incf (world-next-mutation-id new-world))
(incf (world-generation new-world))
(values new-world mutation t)))))
;;; 7-11: Other mutations follow same pattern (rewrite-dispatch, install-macro, remove-binding, commit-generation, rollback-generation)
;;; ============================================================================
;;; PART 8: THEOREM EVIDENCE STRUCTURES
;;; ============================================================================
;;; Evidence for T08: MutationJournalCompleteness
(defun evidence-t08-journal-completeness (world mutable-change-occurred mutation-id)
"For every mutable change, a journal entry exists."
(check-type world world)
(check-type mutable-change-occurred boolean)
(check-type mutation-id object-id)
(if mutable-change-occurred
(let ((found nil))
(loop for event across (world-mutation-journal world)
when (= (mutation-event-mutation-id event) mutation-id)
do (setf found t))
found)
t))
;;; Evidence for T09: FailedMutationAtomicity
(defun evidence-t09-failed-mutation-atomicity (original-world mutation-result)
"Failed mutation doesn't change canonical world."
(check-type original-world world)
(check-type mutation-result t)
(let ((accepted (gethash :accepted mutation-result))
(result-world (gethash :world mutation-result)))
(if (not accepted)
;; If rejected: world must be identical
(equal (format nil "~A" original-world) (format nil "~A" result-world))
;; If accepted: world changed
t)))
;;; Evidence for T11: GenerationMonotonicity
(defun evidence-t11-generation-monotonicity (world event)
"Every mutation increases generation."
(check-type world world)
(check-type event mutation-event)
(< (mutation-event-generation-before event)
(mutation-event-generation-after event)))
(provide 'mutation-model)
|