;
; level7-runner-v2.scm
;
; Level 7: Meta-rules about rules, with DISCOVERED domains.
;
; Key improvement over v1: Domains are NOT hand-labeled.
; Instead, they EMERGE from conflict-clustering:
; 1. Start with rules and their conflict patterns
; 2. Rules that conflict with the same opponents cluster together
; 3. Each cluster IS a domain, named by its medoid rule
; 4. Priority between domains comes from counting which wins
;
; This applies the same COUNT -> CLUSTER -> STRUCTURE method
; to the rules themselves, one level higher.
;
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-69))
(use-modules (ice-9 format))
(display "═══════════════════════════════════════════════════════════════════\n")
(display " LEVEL 7 v2: With Discovered Domains \n")
(display " (Domains emerge from conflict-clustering, not hand-labels) \n")
(display "═══════════════════════════════════════════════════════════════════\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STEP 1: DEFINE RULES (the raw data)
;;
;; Rules are the "words" of this level. We'll discover their
;; structure the same way we discovered word structure in Level 2.
;; The rule DESCRIPTIONS are the input text; the domains will emerge.
;; ═══════════════════════════════════════════════════════════════════
(display "STEP 1: Rules (raw data -- no domain labels)\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; Each rule has: (id description confidence)
;; NO domain label -- that's what we'll discover.
(define rules '(
(R1 "objects fall when dropped" 0.99)
(R2 "humans cannot teleport" 0.99)
(R3 "heavier-than-air things don't float" 0.95)
(R4 "fire is hot and burns" 0.98)
(R5 "humans need to eat regularly" 0.95)
(R6 "humans need to sleep" 0.93)
(R7 "living things eventually die" 0.97)
(R8 "don't run into traffic" 0.98)
(R9 "don't touch hot stoves" 0.96)
(R10 "keep children away from edges" 0.94)
(R11 "be polite to strangers" 0.80)
(R12 "wait your turn in line" 0.75)
(R13 "share resources fairly" 0.70)
(R14 "people want comfort" 0.85)
(R15 "people want to avoid pain" 0.90)
(R16 "people want social approval" 0.80)
(R17 "penguins cannot fly" 0.98)
(R18 "birds can fly" 0.85)
(R19 "fish live in water" 0.97)
(R20 "dogs are loyal pets" 0.80)
(R21 "recent information overrides old" 0.75)
(R22 "local customs vary by region" 0.70)
))
(display " Rules (no domain labels assigned):\n\n")
(for-each
(lambda (r)
(format #t " ~a: ~a (conf: ~,0f%)\n" (car r) (cadr r) (* 100 (caddr r))))
(take rules 10))
(display " ...\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STEP 2: TRAINING CONFLICTS
;;
;; These are observed situations where two rules conflict.
;; The WINNER is recorded. This is our "corpus" for meta-rules.
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 2: Observed Conflicts (training data)\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; (rule-a-id rule-b-id winner-id situation-description)
(define conflicts '(
;; Physical rules vs desire
(R1 R14 R1 "wanting to fly doesn't override gravity")
(R2 R14 R2 "wanting to teleport doesn't make it possible")
(R1 R16 R1 "social approval doesn't override gravity")
(R4 R14 R4 "fire burns regardless of comfort desire")
(R2 R15 R2 "wanting to avoid pain doesn't enable teleportation")
;; Physical rules vs social
(R1 R11 R1 "gravity works even when being polite")
(R3 R12 R3 "heavy things sink even in an orderly queue")
(R4 R13 R4 "fire is hot regardless of fair sharing")
;; Biological vs social
(R5 R12 R5 "eating trumps waiting in line when starving")
(R6 R11 R6 "sleep need trumps being polite when exhausted")
(R5 R13 R5 "hunger overrides sharing norms")
(R7 R16 R7 "mortality doesn't care about social approval")
;; Biological vs desire
(R5 R14 R5 "hunger overrides comfort preference")
(R6 R14 R6 "sleep need overrides comfort preference")
(R7 R15 R7 "mortality overrides desire to avoid pain")
;; Safety vs social
(R8 R12 R8 "safety trumps waiting your turn")
(R9 R11 R9 "don't touch stove trumps being polite")
(R10 R13 R10 "child safety trumps fair sharing")
;; Safety vs desire
(R8 R14 R8 "safety trumps comfort")
(R9 R15 R9 "safety rule trumps pain avoidance in specific case")
;; Physical vs biological
(R1 R5 R1 "gravity overrides hunger")
(R4 R6 R4 "fire burns even if you're tired")
;; Specific vs general
(R17 R18 R17 "penguin-specific trumps bird-general")
(R19 R18 R19 "fish-specific trumps bird rule in water context")
;; Social vs desire
(R11 R14 R11 "politeness norms override personal comfort")
(R12 R15 R12 "queue norms override impatience")
))
(format #t " Training conflicts: ~a observed situations\n\n" (length conflicts))
(for-each
(lambda (c)
(format #t " ~a vs ~a -> ~a wins (~a)\n"
(car c) (cadr c) (caddr c) (cadddr c)))
(take conflicts 8))
(display " ...\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STEP 3: DISCOVER DOMAINS via Conflict-Clustering
;;
;; Key insight: Rules that CONFLICT WITH THE SAME OPPONENTS are
;; in the same "domain". This is the same as: words that CO-OCCUR
;; WITH THE SAME WORDS are in the same cluster.
;;
;; We build a "conflict profile" for each rule (who does it beat?
;; who beats it?) and cluster rules by profile similarity.
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 3: Discovering Domains via Conflict-Clustering\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; Build conflict profiles: for each rule, which rules does it beat/lose to?
(define rule-beats (make-hash-table eq?)) ;; rule -> list of rules it beats
(define rule-loses (make-hash-table eq?)) ;; rule -> list of rules it loses to
(for-each
(lambda (conflict)
(let ((ra (car conflict))
(rb (cadr conflict))
(winner (caddr conflict)))
(if (eq? winner ra)
(begin
(hash-table-set! rule-beats ra
(cons rb (hash-table-ref/default rule-beats ra '())))
(hash-table-set! rule-loses rb
(cons ra (hash-table-ref/default rule-loses rb '()))))
(begin
(hash-table-set! rule-beats rb
(cons ra (hash-table-ref/default rule-beats rb '())))
(hash-table-set! rule-loses ra
(cons rb (hash-table-ref/default rule-loses ra '())))))))
conflicts)
(display " Conflict profiles:\n\n")
(for-each
(lambda (r)
(let ((id (car r)))
(let ((beats (delete-duplicates (hash-table-ref/default rule-beats id '())))
(loses (delete-duplicates (hash-table-ref/default rule-loses id '()))))
(when (or (not (null? beats)) (not (null? loses)))
(format #t " ~a beats: ~a, loses to: ~a\n" id beats loses)))))
rules)
(newline)
;; Compute conflict-profile similarity between rules (Sorensen-Dice coefficient).
;; Rules with similar beat/lose profiles are in the same domain.
;; De-duplicate profiles to prevent inflated similarity scores.
(define (conflict-similarity r1 r2)
(let* ((beats1 (delete-duplicates (hash-table-ref/default rule-beats r1 '())))
(beats2 (delete-duplicates (hash-table-ref/default rule-beats r2 '())))
(loses1 (delete-duplicates (hash-table-ref/default rule-loses r1 '())))
(loses2 (delete-duplicates (hash-table-ref/default rule-loses r2 '())))
(shared-beats (length (lset-intersection eq? beats1 beats2)))
(shared-loses (length (lset-intersection eq? loses1 loses2)))
(total1 (+ (length beats1) (length loses1)))
(total2 (+ (length beats2) (length loses2))))
(if (and (> total1 0) (> total2 0))
(/ (* 2.0 (+ shared-beats shared-loses))
(+ total1 total2))
0.0)))
;; Get rules that participate in conflicts
(define active-rules
(filter (lambda (r)
(let ((id (car r)))
(or (not (null? (hash-table-ref/default rule-beats id '())))
(not (null? (hash-table-ref/default rule-loses id '()))))))
rules))
;; Agglomerative clustering of rules by conflict-profile similarity
(define (cluster-rules threshold)
(let ((clusters (map (lambda (r) (list (car r))) active-rules)))
(define (cluster-sim c1 c2)
(if (or (null? c1) (null? c2))
0.0
(let* ((pairs (append-map
(lambda (r1)
(map (lambda (r2) (conflict-similarity r1 r2)) c2))
c1))
(n (length pairs)))
(if (= n 0) 0.0 (/ (apply + pairs) n)))))
(define (find-best cls)
(let ((best-sim -1.0) (best-i 0) (best-j 1) (n (length cls)))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j (+ i 1) (+ j 1))) ((>= j n))
(let ((sim (cluster-sim (list-ref cls i) (list-ref cls j))))
(when (> sim best-sim)
(set! best-sim sim)
(set! best-i i)
(set! best-j j)))))
(values best-i best-j best-sim)))
(let loop ((cls clusters))
(if (<= (length cls) 1)
cls
(call-with-values
(lambda () (find-best cls))
(lambda (i j sim)
(if (< sim threshold)
cls
(let* ((ci (list-ref cls i))
(cj (list-ref cls j))
(merged (append ci cj))
(rest (filter (lambda (c)
(and (not (equal? c ci))
(not (equal? c cj))))
cls)))
(loop (cons merged rest))))))))))
(define discovered-domains (cluster-rules 0.25))
;; Name each domain by its most powerful rule (most wins)
(define (domain-medoid domain)
(let ((best-rule #f) (best-wins -1))
(for-each
(lambda (rule-id)
(let ((wins (length (hash-table-ref/default rule-beats rule-id '()))))
(when (> wins best-wins)
(set! best-wins wins)
(set! best-rule rule-id))))
domain)
best-rule))
(define named-domains
(map (lambda (domain)
(cons (domain-medoid domain) domain))
discovered-domains))
(display " DISCOVERED DOMAINS (named by medoid rule):\n\n")
(for-each
(lambda (nd)
(let ((medoid (car nd))
(members (cdr nd)))
(format #t " [~a]-domain: ~a\n" medoid members)
;; Show the medoid rule's description
(let ((rule-entry (assoc medoid rules)))
(when rule-entry
(format #t " (medoid: '~a')\n" (cadr rule-entry))))))
named-domains)
(newline)
(display " These domains were DISCOVERED, not hand-labeled.\n")
(display " The system doesn't know 'PHYSICAL' or 'SOCIAL'.\n")
(display " It knows '[R1]-domain' and '[R11]-domain' (or whatever\n")
(display " the medoid rule turns out to be).\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STEP 4: BUILD PRIORITY HIERARCHY (COMPUTED)
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 4: Computing Domain Priority Hierarchy\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; Count wins between domains
(define domain-wins (make-hash-table equal?))
;; Find which domain a rule belongs to
(define (rule-domain rule-id)
(let loop ((domains named-domains))
(if (null? domains)
#f
(if (member rule-id (cdar domains))
(caar domains)
(loop (cdr domains))))))
;; Count inter-domain wins from conflict data
(for-each
(lambda (conflict)
(let* ((ra (car conflict))
(rb (cadr conflict))
(winner (caddr conflict))
(da (rule-domain ra))
(db (rule-domain rb)))
(when (and da db (not (eq? da db)))
(let ((winner-domain (rule-domain winner))
(key (cons da db)))
(when winner-domain
(let ((current (hash-table-ref/default domain-wins key (cons 0 0))))
(if (eq? winner-domain da)
(hash-table-set! domain-wins key
(cons (+ 1 (car current)) (cdr current)))
(hash-table-set! domain-wins key
(cons (car current) (+ 1 (cdr current)))))))))))
conflicts)
;; Build beats-direct relation between domains (>60% win rate)
(define domain-beats-direct (make-hash-table eq?))
(hash-table-walk domain-wins
(lambda (key counts)
(let* ((da (car key))
(db (cdr key))
(a-wins (car counts))
(b-wins (cdr counts))
(total (+ a-wins b-wins)))
(when (> total 0)
(let ((a-rate (/ a-wins total)))
(cond
((> a-rate 0.6)
(hash-table-set! domain-beats-direct da
(cons db (hash-table-ref/default domain-beats-direct da '()))))
((< a-rate 0.4)
(hash-table-set! domain-beats-direct db
(cons da (hash-table-ref/default domain-beats-direct db '()))))))))))
(display " Direct domain priority (from conflict counts):\n\n")
(hash-table-walk domain-beats-direct
(lambda (domain beats)
(format #t " [~a]-domain > ~a\n" domain beats)))
(newline)
;; Transitive closure
(define domain-beats-transitive (make-hash-table eq?))
(hash-table-walk domain-beats-direct
(lambda (k v) (hash-table-set! domain-beats-transitive k (list-copy v))))
;; Collect transitive additions first, then apply them (avoid
;; mutating hash table during walk, which is undefined in SRFI-69).
(define (add-transitive-domains)
(let ((changes '()))
;; Collect needed additions
(hash-table-walk domain-beats-transitive
(lambda (a a-beats)
(for-each
(lambda (b)
(let ((b-beats (hash-table-ref/default domain-beats-transitive b '())))
(for-each
(lambda (c)
(unless (or (eq? a c) (member c a-beats))
(set! changes (cons (cons a c) changes))))
b-beats)))
a-beats)))
;; Apply collected changes
(for-each
(lambda (change)
(let* ((a (car change))
(c (cdr change))
(current (hash-table-ref/default domain-beats-transitive a '())))
(unless (member c current)
(hash-table-set! domain-beats-transitive a (cons c current)))))
changes)
(not (null? changes))))
(let loop ((iterations 0))
(when (and (add-transitive-domains) (< iterations 10))
(loop (+ 1 iterations))))
(display " After transitive closure:\n\n")
(hash-table-walk domain-beats-transitive
(lambda (domain beats)
(format #t " [~a]-domain > ~a\n" domain beats)))
(newline)
;; Derive total order by counting how many domains each beats
(define domain-scores '())
(hash-table-walk domain-beats-transitive
(lambda (domain beats)
(set! domain-scores (cons (cons domain (length beats)) domain-scores))))
(set! domain-scores
(sort domain-scores (lambda (a b) (> (cdr a) (cdr b)))))
(display " Priority hierarchy (most powerful first):\n\n")
(for-each
(lambda (entry)
(let ((rule-entry (assoc (car entry) rules)))
(format #t " [~a]-domain (beats ~a) -- '~a'\n"
(car entry) (cdr entry)
(if rule-entry (cadr rule-entry) "?"))))
domain-scores)
(newline)
;; ═══════════════════════════════════════════════════════════════════
;; STEP 5: PREDICTION FUNCTION
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 5: Prediction Function with Discovered Domains\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; Compute win rate between two domains from the domain-wins table.
;; Returns the win rate for domain da over db (0.0 to 1.0).
(define (domain-win-rate da db)
(let* ((key-ab (cons da db))
(key-ba (cons db da))
(counts-ab (hash-table-ref/default domain-wins key-ab (cons 0 0)))
(counts-ba (hash-table-ref/default domain-wins key-ba (cons 0 0)))
;; a-wins = ab.car (a wins in a-vs-b) + ba.cdr (a wins in b-vs-a)
(a-wins (+ (car counts-ab) (cdr counts-ba)))
;; b-wins = ab.cdr + ba.car
(b-wins (+ (cdr counts-ab) (car counts-ba)))
(total (+ a-wins b-wins)))
(if (= total 0) 0.5 (/ a-wins total))))
(define (predict-winner rule-a-id rule-b-id)
"Predict winner by finding which rule's domain is stronger."
(let ((da (rule-domain rule-a-id))
(db (rule-domain rule-b-id)))
(cond
((not (and da db))
(values 'UNKNOWN 0.50 'NO-DOMAIN))
((eq? da db)
;; Same domain: use confidence
(let ((conf-a (caddr (assoc rule-a-id rules)))
(conf-b (caddr (assoc rule-b-id rules))))
(if (> conf-a conf-b)
(values rule-a-id conf-a 'SAME-DOMAIN-CONFIDENCE)
(values rule-b-id conf-b 'SAME-DOMAIN-CONFIDENCE))))
(else
;; Different domains: use domain hierarchy with computed win rate
(let ((a-beats (hash-table-ref/default domain-beats-transitive da '()))
(b-beats (hash-table-ref/default domain-beats-transitive db '())))
(cond
((member db a-beats)
(values rule-a-id (domain-win-rate da db) 'DOMAIN-PRIORITY))
((member da b-beats)
(values rule-b-id (domain-win-rate db da) 'DOMAIN-PRIORITY))
(else
(values 'UNKNOWN 0.50 'NO-PRIORITY-DATA))))))))
(display " Prediction function uses discovered domain hierarchy.\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STEP 6: TEST ON NOVEL CONFLICTS
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 6: Test on NOVEL Conflicts\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
;; Novel test cases: conflicts NOT in training data
(define novel-tests '(
(R2 R16 R2 "can't teleport for social approval")
(R3 R15 R3 "heavy things sink despite desire")
(R5 R11 R5 "hunger vs politeness")
(R8 R15 R8 "safety vs pain avoidance")
(R10 R16 R10 "child safety vs social approval")
(R7 R14 R7 "mortality vs comfort desire")
(R4 R12 R4 "fire danger vs queue norms")
))
(define novel-correct 0)
(define novel-total 0)
(for-each
(lambda (test)
(let ((ra (car test))
(rb (cadr test))
(expected (caddr test))
(description (cadddr test)))
(call-with-values
(lambda () (predict-winner ra rb))
(lambda (predicted confidence method)
(let ((correct (eq? predicted expected)))
(format #t " ~a vs ~a (~a)\n" ra rb description)
(format #t " Domain(~a)=[~a], Domain(~a)=[~a]\n"
ra (or (rule-domain ra) "?")
rb (or (rule-domain rb) "?"))
(format #t " Predicted: ~a (method: ~a)\n" predicted method)
(format #t " Expected: ~a -> ~a\n\n" expected (if correct "CORRECT" "WRONG"))
(set! novel-total (+ 1 novel-total))
(when correct (set! novel-correct (+ 1 novel-correct))))))))
novel-tests)
(format #t " Novel conflict accuracy: ~a/~a (~,0f%)\n\n"
novel-correct novel-total (* 100.0 (/ novel-correct novel-total)))
;; ═══════════════════════════════════════════════════════════════════
;; STEP 7: FULL SENTENCE ANALYSIS
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "STEP 7: Full Sentence Analysis Examples\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
(define (analyze-conflict sentence rule-a rule-b)
(let ((ra-id (car rule-a))
(rb-id (car rule-b))
(ra-desc (cadr rule-a))
(rb-desc (cadr rule-b))
(ra-conf (caddr rule-a))
(rb-conf (caddr rule-b)))
(format #t " SENTENCE: '~a'\n\n" sentence)
(format #t " Rule A: ~a -- '~a' (conf: ~,0f%)\n" ra-id ra-desc (* 100 ra-conf))
(format #t " Rule B: ~a -- '~a' (conf: ~,0f%)\n" rb-id rb-desc (* 100 rb-conf))
(format #t " Domain(~a) = [~a]\n" ra-id (or (rule-domain ra-id) "?"))
(format #t " Domain(~a) = [~a]\n\n" rb-id (or (rule-domain rb-id) "?"))
(call-with-values
(lambda () (predict-winner ra-id rb-id))
(lambda (winner confidence method)
(format #t " META-RULE: [~a]-domain wins (via ~a)\n" winner method)
(let ((winning-conf (if (eq? winner ra-id) ra-conf rb-conf)))
(cond
((< winning-conf 0.3)
(display " VERDICT: ANOMALOUS - violates winning rule\n")
(display " ACTION: Flag as error/metaphor/fiction\n"))
((> winning-conf 0.7)
(display " VERDICT: VALID - consistent with winning rule\n"))
(else
(display " VERDICT: UNCERTAIN - moderate confidence\n"))))))
(display "\n─────────────────────────────────────────────────────────────────\n\n")))
(analyze-conflict
"The penguin flew to the iceberg"
'(R18 "birds can fly" 0.85)
'(R17 "penguins cannot fly" 0.98))
(analyze-conflict
"John wanted to teleport to work"
'(R14 "people want comfort" 0.85)
'(R2 "humans cannot teleport" 0.99))
(analyze-conflict
"She skipped lunch to finish the report"
'(R5 "humans need to eat regularly" 0.95)
'(R12 "wait your turn in line" 0.75))
(analyze-conflict
"The child ran into traffic to get the ball"
'(R12 "wait your turn in line" 0.75)
'(R8 "don't run into traffic" 0.98))
;; ═══════════════════════════════════════════════════════════════════
;; SUMMARY
;; ═══════════════════════════════════════════════════════════════════
(display "═══════════════════════════════════════════════════════════════════\n")
(display "SUMMARY\n")
(display "─────────────────────────────────────────────────────────────────\n\n")
(display " KEY IMPROVEMENT: Discovered domains (no hand-labels)\n\n")
(display " Before: Domains were PHYSICAL, BIOLOGICAL, SOCIAL, DESIRE\n")
(display " (hand-labeled -- violated core method)\n")
(display " After: Domains emerge from conflict-clustering\n")
(display " Named by medoid rule, not by human\n\n")
(format #t " Training conflicts: ~a\n" (length conflicts))
(format #t " Discovered domains: ~a\n" (length discovered-domains))
(format #t " Novel test accuracy: ~a/~a (~,0f%)\n\n"
novel-correct novel-total (* 100.0 (/ novel-correct novel-total)))
(display " Discovered domain hierarchy:\n")
(for-each
(lambda (entry)
(format #t " [~a] (beats ~a)\n" (car entry) (cdr entry)))
domain-scores)
(newline)
(display " Level 7 capabilities demonstrated:\n")
(display " - Discover rule domains from conflict patterns (COMPUTED)\n")
(display " - Name domains by medoid rule (no human labels)\n")
(display " - Build priority hierarchy from counted wins\n")
(display " - Transitive inference (A>B, B>C -> A>C)\n")
(display " - Predict winners on novel conflicts\n")
(display " - Same COUNT -> CLUSTER -> STRUCTURE method as Levels 1-6\n\n")
(display " The method is the same at every level:\n")
(display " Level 2: Count word co-occurrences -> cluster words\n")
(display " Level 3: Count cluster co-occurrences -> frames\n")
(display " Level 7: Count rule conflicts -> cluster rules into domains\n")
(display " The recursion continues as long as new structure emerges.\n\n")