#lang racket/base
;; Gestalts: representations of (replicated) state.

(require racket/set)
(require racket/match)

(require "route.rkt")

(provide (struct-out gestalt)
	 gestalt-ref
	 compile-gestalt-projection
	 gestalt-project
	 gestalt-project->finite-set
	 drop-gestalt
	 lift-gestalt
	 simple-gestalt
	 gestalt-empty
	 gestalt-empty?
	 gestalt-combine
	 gestalt-combine-straight
	 gestalt-combine-crossed
	 gestalt-union
	 gestalt-intersect
	 gestalt-filter
	 gestalt-match
	 strip-gestalt-label
	 label-gestalt
	 pretty-print-gestalt)

;; A Gestalt is a (gestalt (Listof (Listof (Pairof Matcher
;; Matcher)))), representing the total interests of a process or group
;; of processes. The outer list has a present entry for each active
;; metalevel, starting with metalevel 0 in the car. The inner lists
;; each have an entry for each active observer level at their
;; metalevel. The innermost pairs have cars holding matchers
;; representing active subscriptions, and cdrs representing active
;; advertisements.
;;
;;    "... a few standardised subsystems, identical from citizen to
;;     citizen. Two of these were channels for incoming data — one for
;;     gestalt, and one for linear, the two primary modalities of all
;;     Konishi citizens, distant descendants of vision and hearing."
;;      -- Greg Egan, "Diaspora"
;;         http://gregegan.customer.netspace.net.au/DIASPORA/01/Orphanogenesis.html
;;
(struct gestalt (metalevels) #:prefab)

;; Convention: A GestaltSet is a Gestalt where all the patterns map to
;; #t rather than a PID or any other value.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (safe-list-ref xs n [fail-thunk (lambda () (error 'safe-list-ref "No such index ~v" n))])
  (let loop ((xs xs) (n n))
    (match xs
      ['() (fail-thunk)]
      [(cons x xs) (if (zero? n) x (loop xs (- n 1)))])))

(define (safe-cdr xs)
  (if (null? xs)
      '()
      (cdr xs)))

(define (gestalt-ref g metalevel level get-advertisements?)
  (define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '())))
  (define p (safe-list-ref v level (lambda () '(#f . #f))))
  ((if get-advertisements? cdr car) p))

(define (compile-gestalt-projection spec)
  (compile-projection spec))

(define (gestalt-project g metalevel level get-advertisements? capture-spec)
  (matcher-project (gestalt-ref g metalevel level get-advertisements?) capture-spec))

(define (gestalt-project->finite-set g metalevel level get-advertisements? capture-spec)
  (matcher->finite-set (gestalt-project g metalevel level get-advertisements? capture-spec)))

(define (drop-gestalt g)
  (match-define (gestalt metalevels) g)
  (if (null? metalevels) g (gestalt (cdr metalevels))))

(define (lift-gestalt g)
  (gestalt (cons '#() (gestalt-metalevels g))))

(define (prepend n x xs)
  (if (zero? n)
      xs
      (cons x (prepend (- n 1) x xs))))

(define (simple-gestalt subs advs level metalevel)
  (gestalt (prepend metalevel '() (list (prepend level '(#f . #f) (list (cons subs advs)))))))

(define (gestalt-empty) (gestalt '()))

(define (gestalt-empty? g)
  (andmap (lambda (ls) (andmap (lambda (l) (and (matcher-empty? (car l)) (matcher-empty? (cdr l)))) ls))
	  (gestalt-metalevels g)))

(define (map-zip imbalance-handler item-handler right-unit ls1 ls2)
  (let walk ((ls1 ls1) (ls2 ls2))
    (match* (ls1 ls2)
      [('() '()) '()]
      [('() ls) (imbalance-handler 'right-longer ls)]
      [(ls '()) (imbalance-handler 'left-longer ls)]
      [((cons l1 ls1) (cons l2 ls2))
       (define new-item (item-handler l1 l2))
       (define new-tail (walk ls1 ls2))
       (if (and (null? new-tail) (equal? new-item right-unit))
	   '()
	   (cons new-item new-tail))])))

(define (gestalt-combine g1 g2 imbalance-handler matcher-pair-combiner)
  (define (yu ls1 ls2) (map-zip imbalance-handler matcher-pair-combiner '(#f . #f) ls1 ls2))
  (define (xu mls1 mls2) (map-zip imbalance-handler yu '() mls1 mls2))
  (gestalt (xu (gestalt-metalevels g1)
	       (gestalt-metalevels g2))))

(define (gestalt-combine-straight g1 g2 imbalance-handler matcher-combiner)
  (gestalt-combine g1 g2
		   imbalance-handler
		   (lambda (sa1 sa2)
		     (cons (matcher-combiner (car sa1) (car sa2))
			   (matcher-combiner (cdr sa1) (cdr sa2))))))

(define (gestalt-combine-crossed g1 g2 imbalance-handler matcher-combiner)
  (gestalt-combine g1 g2
		   imbalance-handler
		   (lambda (sa1 sa2)
		     (cons (matcher-combiner (car sa1) (cdr sa2))
			   (matcher-combiner (car sa2) (cdr sa1))))))

(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2
							 (lambda (side x) x)
							 matcher-union))

(define (gestalt-union . gs)
  (if (null? gs)
      (gestalt-empty)
      (let walk ((gs gs))
	(match gs
	  [(list g) g]
	  [(cons g rest) (gestalt-union1 g (walk rest))]))))

(define (gestalt-intersect g1 g2) (gestalt-combine-straight g1 g2
							    (lambda (side x) '())
							    matcher-intersect))

;; View on g1 from g2's perspective.
;; Drops a level from g2 and intersects crossed.
(define (gestalt-filter g1 g2)
  (gestalt-combine-crossed g1
			   (gestalt (map safe-cdr (gestalt-metalevels g2)))
			   (lambda (side x) '())
			   (lambda (g1 g2) (matcher-intersect g1 g2
							      (lambda (v1 v2) v1)))))

(define (gestalt-match g1 g2)
  (define (zu sa1 sa2)
    (define-values (a1 a2) (matcher-match-matcher (car sa1) (car sa2)))
    (define-values (d1 d2) (matcher-match-matcher (cdr sa1) (cdr sa2)))
    (values (set-union a1 d1) (set-union a2 d2)))
  (define (mz xs1 xs2 f)
    (match* (xs1 xs2)
      [('() xs) (values (set) (set))]
      [(xs '()) (values (set) (set))]
      [((cons x1 xs1) (cons x2 xs2))
       (define-values (r1 r2) (mz xs1 xs2 f))
       (define-values (v1 v2) (f x1 x2))
       (values (set-union v1 r1) (set-union v2 r2))]))
  (define (yu ls1 ls2) (mz ls1 ls2 zu))
  (define (xu mls1 mls2) (mz mls1 mls2 yu))
  (xu (gestalt-metalevels g1)
      (gestalt-metalevels g2)))

(define (gestalt-matcher-transform g f)
  (define (zu sa) (cons (f (car sa)) (f (cdr sa))))
  (define (yu ls) (map zu ls))
  (define (xu mls) (map yu mls))
  (gestalt (xu (gestalt-metalevels g))))

(define (strip-gestalt-label g)
  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set #t))))))

(define (label-gestalt g pid)
  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set pid))))))

(define (pretty-print-gestalt g [port (current-output-port)])
  (for [(metalevel (in-naturals)) (ls (in-list (gestalt-metalevels g)))]
    (for [(level (in-naturals)) (l (in-list ls))]
      (match-define (cons subs advs) l)
      (when (or subs advs)
	(fprintf port "GESTALT metalevel ~v level ~v:\n" metalevel level)
	(when subs (fprintf port "  - subs:") (pretty-print-matcher subs port #:indent 9))
	(when advs (fprintf port "  - advs:") (pretty-print-matcher advs port #:indent 9))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module+ test
  (require rackunit)

  (check-equal? (simple-gestalt 'a 'b 0 0)
		(gestalt (list (list (cons 'a 'b)))))
  (check-equal? (simple-gestalt 'a 'b 2 2)
		(gestalt (list '() '() (list '(#f . #f)
					     '(#f . #f)
					     (cons 'a 'b))))))