(module sharing mzscheme

  (require (lib "contract.ss")
           (lib "plt-match.ss")
           (lib "list.ss")
           (lib "etc.ss")
           (only (lib "1.ss" "srfi") partition)
           (planet "combinators.ss" ("cce" "combinators.plt" 1 4))
           "syntax-errors.scm"
           "tags.scm"
           "idmap.scm")

  ;; A Sharing is (make-sharing order groups)
  ;; order : (IDMap Number) defines an ordering for shared identifiers;
  ;;  external identifiers are mapped to -1.
  ;; groups : (Listof (Listof Identifier)) defines the equivalence classes.
  (define-struct sharing (order groups))

  (provide/contract
   [sharing? (-> any/c boolean?)]
   [sharing-empty? (-> sharing? boolean?)]
   [empty-sharing (-> (listof identifier?) sharing?)]
   [sharing-add-clauses
    (-> (listof (listof identifier?)) boolean? sharing? sharing?)]
   [sharing-representative? (-> sharing? identifier? boolean?)]
   [sharing-representative (-> sharing? identifier? identifier?)]
   [sharing-remove (-> sharing? (listof identifier?) sharing?)]
   [sharing->renaming (-> sharing? idmap?)]
   [sharing-subset? (-> sharing? sharing? boolean?)]
   [sharing-union (-> sharing? sharing? sharing?)]
   [sharing-retag (-> (alistof identifier? identifier?) sharing? sharing?)]
   [sharing->sexp (-> sharing? (listof (listof symbol?)))])

  (define (sharing-empty? s)
    (null? (sharing-groups s)))

  (define (empty-sharing ids)
    (make-sharing (list->order ids) null))

  (define (list->order ids)
    (let* ([order (empty-idmap)]
           [count 0])
      (for-each
       (lambda (id)
         (set! count (+ count 1))
         (idmap-put-unique! order id count))
       ids)
      order))

  (define (sharing-add-clauses cs before? s)
    (foldl (curry sharing-add-clause before?) s cs))

  (define (sharing-add-clause before? c s)
    (let* ([groups (sharing-groups s)]
           [order (sharing-order s)]
           [_ (for-each (curry order-add! order before?) c)]
           [clause (sort-clause order c)])
      (let*-values ([(hits rest)
                     (partition (curry clause-intersects? clause) groups)])
        (make-sharing
         order
         (cons (merge-clauses order (cons clause hits)) rest)))))

  (define (clause-intersects? one two)
    (ormap (curry clause-contains? one) two))

  (define (clause-contains? clause id)
    (ormap (curry id=? id) clause))

  (define (sort-clause order clause)
    (let* ([id<? (order->less-than order)])
      (uniquify-clause id<? (sort clause id<?))))

  (define (uniquify-clause id<? clause)
    (cond
     [(null? clause) clause]
     [(null? (cdr clause)) clause]
     [(id<? (car clause) (cadr clause))
      (cons (car clause) (uniquify-clause id<? (cdr clause)))]
     [(id=? (car clause) (cadr clause))
      (uniquify-clause id<? (cdr clause))]
     [else
      (syntax-error (car clause) "inconsistent constraint: ~s = ~s"
                    (syntax-e (car clause)) (syntax-e (cdr clause)))]))

  (define (merge-clauses order clauses)
    (sort-clause order (apply append clauses)))

  (define (order-add! order before? id)
    (unless (idmap-member? order id)
      (idmap-put! order id before?)))

  (define (order->less-than order)
    (lambda (one two)
      (index<? (order-index order one) (order-index order two))))

  (define index<?
    (match-lambda*
     [(list (? number? a) (? number? b)) (< a b)]
     [(list _ #t) #f]
     [(list #f _) #f]
     [_ #t]))

  (define (order-index order id)
    (idmap-get
     order id
     (lambda ()
       (syntax-error id "not registered in sharing constraints"))))

  (define (sharing-representative s id)
    (let* ([clause (findf (lambda (clause) (clause-contains? clause id))
                          (sharing-groups s))])
      (if clause (car clause) id)))

  (define (sharing-representative? s id)
    (id=? id (sharing-representative s id)))

  (define (sharing-remove s ids)
    (make-sharing (sharing-order s)
                  (filter
                   pair?
                   (map (curry clause-remove ids) (sharing-groups s)))))

  (define (clause-remove ids clause)
    (filter (lambda (id) (not (clause-contains? ids id))) clause))

  (define (sharing->renaming s)
    (alist->idmap
     (map (lambda (id)
            (cons id (sharing-representative s id)))
          (idmap-domain (sharing-order s)))))

  (define (sharing-subset? one two)
    (let* ([one (sharing->map-of-sets one)]
           [two (sharing->map-of-sets two)])
      (andmap
       (lambda (id)
         (idset-subset?
          (idmap-get one id (lambda () (sharing-id-vanished! id)))
          (idmap-get two id (lambda () (list->idset (list id))))))
       (idmap-domain one))))

  (define (sharing-id-vanished! id)
    (syntax-error id "id ~s vanished from sharing constraints" (syntax-e id)))

  (define (sharing->map-of-sets s)
    (let* ([clauses (sharing-groups s)]
           [idmap (empty-idmap)])
      (for-each
       (lambda (clause)
         (let* ([idset (list->idset clause)])
           (for-each
            (lambda (id)
              (idmap-put-unique! idmap id idset))
            clause)))
       clauses)
      idmap))

  (define (sharing-union one two)
    (sharing-add-clauses
     (append (sharing-groups one) (sharing-groups two))
     #f
     (make-sharing (order-union (sharing-order one) (sharing-order two)) null)))

  (define (order-union one two)
    (let* ([new (empty-idmap)]
           [count 0]
           [count (order-union/count! new count one)]
           [count (order-union/count! new count two)])
      new))

  (define (order-union/count! dest base src)
    (let* ([count 0])
      (idmap-for-each
       src
       (lambda (id index)
         (when (number? index)
           (set! count (max count (+ index 1))))
         (unless (idmap-member? dest id)
           (idmap-put!
            dest id
            (if (number? index) (+ index base) index)))))
      (+ base count)))

  (define (sharing-retag alist s)
    (sharing-rename (tag-renaming alist s) s))

  (define (renaming->sexp idmap)
    (map (lambda (pair)
           (cons (syntax-e (car pair))
                 (syntax-e (cdr pair))))
         (idmap->alist idmap)))

  (define (sharing-rename idmap s)
    (sharing-add-clauses
     (map (curry clause-rename idmap) (sharing-groups s))
     #f
     (make-sharing (order-rename idmap (sharing-order s)) null)))

  (define (clause-rename idmap ids)
    (map (curry rename idmap) ids))

  (define (rename idmap id)
    (idmap-get idmap id (lambda () id)))

  (define (order-rename idmap old)
    (let* ([new (empty-idmap)])
      (idmap-for-each
       old
       (lambda (id index)
         (let* ([name (rename idmap id)])
           (when (or (not (idmap-member? new name))
                     (index<? index (idmap-get new name)))
             (idmap-put! new name index)))))
      new))

  (define (tag-renaming alist s)
    (let* ([tags (alist->idmap alist)]
           [order (sharing-order s)]
           [renaming (empty-idmap)])
      (idmap-for-each
       order
       (lambda (id index)
         (when (number? index)
           (idmap-put! renaming id (retag tags id)))))
      renaming))

  (define (sharing->sexp sharing)
    (map (curry map syntax-e) (sharing-groups sharing)))

  )