typesetting/quad/quad/quad.rkt

#lang debug racket/base
(require (for-syntax racket/base racket/syntax)
         racket/struct
         racket/format
         racket/list
         racket/string
         racket/promise
         racket/dict
         racket/match
         "param.rkt"
         "rebase.rkt")
(provide (all-defined-out))

(module+ test (require rackunit))

(define (size q)
  (match (quad-size q)
    [(? procedure? proc) proc (proc q)]
    [(? promise? prom) (force prom)]
    [val val]))

(define (printable? q [signal #f])
  (match (quad-printable q)
    [(? procedure? proc) (proc q signal)]
    [val val]))

(define (draw q [surface (current-output-port)])
  ((quad-draw-start q) q surface)
  ((quad-draw q) q surface)
  ((quad-draw-end q) q surface))

(define (hashes-equal? h1 h2)
  (and (= (length (hash-keys h1)) (length (hash-keys h2)))
       (for/and ([(k v) (in-hash h1)])
                (and (hash-has-key? h2 k) (equal? (hash-ref h2 k) v)))))

(define (quad=? q1 q2 [recur? #t])
  (and
   ;; exclude attrs from initial comparison
   (for/and ([getter (in-list (list quad-elems quad-size quad-from-parent quad-from quad-to 
                                    quad-shift quad-shift-elems quad-from-parent quad-origin quad-printable
                                    quad-draw-start quad-draw-end quad-draw))])
            (equal? (getter q1) (getter q2)))
   ;; and compare them key-by-key
   (hashes-equal? (quad-attrs q1) (quad-attrs q2))))

;; keep this param here so you don't have to import quad/param to get it
(define verbose-quad-printing? (make-parameter #f))

(struct quad (
              ;; WARNING
              ;; atomize procedure depends on attrs & elems
              ;; being first two fields of struct.
              attrs ; key-value pairs, arbitrary
              elems ; subquads or text
              ;; size is a two-dim pt
              size ; outer size of quad for layout (though not necessarily the bounding box for drawing)
              ;; from-parent, from, to are phrased in terms of cardinal position
              from-parent ; alignment point on parent. if not #f, supersedes `from`
              ;; (this way, `from` doens't change, so a quad can "remember" its default `from` attachment point)
              from ; alignment point on ref quad
              to ; alignment point on this quad that is matched to `from` on previous quad
              ;; shift-elements, shift are two-dim pts
              ;; shift-elements = Similar to `relative` CSS positioning
              ;; moves origin for elements . Does NOT change layout position of parent.
              shift-elems
              ;; shift = shift between previous out point and current in point.
              ;; DOES change the layout position.
              shift
              ;; reference point (in absolute coordinates)
              ;; for all subsequent drawing ops in the quad. Calculated, not set directly
              origin 
              printable ; whether the quad will print
              draw-start ; func called at the beginning of every draw event (for setup ops)
              draw ; func called in the middle of every daw event
              draw-end ; func called at the end of every draw event (for teardown ops)
              name ; for anchor resolution
              tag) ; from q-expr, maybe
  #:mutable
  #:transparent
  #:property prop:custom-write
  (λ (q p w?) (display
               (format "<~a-~a~a~a>"
                       (quad-tag q)
                       (object-name q)
                       (if (verbose-quad-printing?)
                           (string-join (map ~v (flatten (hash->list (quad-attrs q))))
                                        " " #:before-first "(" #:after-last ")")
                           "")
                       (match (quad-elems q)
                         [(? pair?) (string-join (map ~v (quad-elems q)) " " #:before-first " ")]
                         [_ ""])) p))
  #:methods gen:equal+hash
  [(define equal-proc quad=?)
   (define (hash-proc h recur) (equal-hash-code h))
   (define (hash2-proc h recur) (equal-secondary-hash-code h))])

#;(struct quad-attr (key default-val) #:transparent)

#;(define (make-quad-attr key [default-val #f])
    (quad-attr key default-val))

(define (quad-ref q key-arg [default-val-arg #f])
  (define key (match key-arg
                #;[(quad-attr key _) key]
                [_ key-arg]))
  (define default-val #;(cond
                          [default-val-arg]
                          [(quad-attr? key-arg) (quad-attr-default-val key-arg)]
                          [else #false]) default-val-arg)
  (hash-ref (quad-attrs q) key default-val))

(define (quad-set! q key val)
  (hash-set! (quad-attrs q) key val)
  q)

(define-syntax (quad-copy stx)
  (syntax-case stx ()
    [(_ QUAD-TYPE ID [K V] ...)
     (if (free-identifier=? #'quad #'QUAD-TYPE)
         #'(struct-copy QUAD-TYPE ID
                        [K V] ...)
         #'(struct-copy QUAD-TYPE ID
                        [K #:parent quad V] ...))]))

(define-syntax (quad-update! stx)
  (syntax-case stx ()
    [(_ ID [K V] ...)
     (with-syntax ([(K-SETTER ...) (for/list ([kstx (in-list (syntax->list #'(K ...)))])
                                             (format-id kstx "set-quad-~a!" kstx))])
       #'(let ([q ID])
           (K-SETTER q V) ...
           q))]))

(define (default-printable q [sig #f]) #t)

(define (default-draw q surface)
  (for-each (λ (qi) (draw qi surface)) (quad-elems q)))

;; why 'nw and 'ne as defaults for in and out points:
;; if size is '(0 0), 'nw and 'ne are the same point,
;; and everything piles up at the origin
;; if size is otherwise, the items don't pile up (but rather lay out in a row)

(define (make-quad-constructor type)
  (make-keyword-procedure (λ (kws kw-args . rest)
                            (keyword-apply make-quad #:type type kws kw-args rest))))

(define (derive-quad-constructor q)
  (define-values (x-structure-type _) (struct-info q))
  (struct-type-make-constructor x-structure-type))

;; todo: convert immutable hashes to mutable on input?
(define (make-quad
         #:tag [tag #false]
         #:type [type quad]
         #:attrs [attrs (make-hasheq)]
         #:elems [elems null]
         #:size [size '(0 0)]
         #:from-parent [from-parent #false]
         #:from [from 'ne]
         #:to [to 'nw]
         #:shift [shift '(0 0)]
         #:shift-elems [shift-elems '(0 0)]
         #:origin [origin '(0 0)]
         #:printable [printable default-printable]
         #:draw-start [draw-start void]
         #:draw [draw default-draw]
         #:draw-end [draw-end void]
         #:name [name #f]
         . args)
  (unless (andmap (λ (x) (not (pair? x))) elems)
    (raise-argument-error 'make-quad "elements that are not lists" elems))
  (match args
    [(list (== #false) elems ...) (make-quad #:elems elems)]
    [(list (? hash? attrs) elems ...) (make-quad #:attrs attrs #:elems elems)]
    [(list (? dict? assocs) elems ...) assocs (make-quad #:attrs (make-hasheq assocs) #:elems elems)]
    [(list elems ..1) (make-quad #:elems elems)]
    ;; all cases end up below
    [null (define args (list
                        attrs
                        elems
                        size
                        from-parent
                        from
                        to
                        shift-elems
                        shift
                        origin
                        printable
                        draw-start
                        draw
                        draw-end
                        name))
          (apply type (append args
                              (list (or tag (string->symbol (~r (eq-hash-code args) #:base 36))))))]))

(define-syntax (define-quad stx)
  (syntax-case stx ()
    [(M ID) #'(M ID quad)]
    [(_ ID SUPER)
     (with-syntax ([MAKE-ID (format-id #'ID "make-~a" (syntax-e #'ID))])
       #'(begin
           (struct ID SUPER ())
           (define MAKE-ID (make-keyword-procedure (λ (kws kw-args . rest)
                                                     (keyword-apply make-quad #:type ID kws kw-args rest))))))]))
  
(define q make-quad)

(define only-prints-in-middle (λ (q sig) (not (memq sig '(start end)))))

(define/match (from-parent qs [where #f])
  ;; doesn't change any positioning. doesn't depend on state. can happen anytime.
  ;; can be repeated without damage.
  [((? null?) _) null]
  [((cons q rest) where)
   (quad-update! q [from-parent (or where (quad-from q))])
   (cons q rest)])

(module+ test
  (require racket/port)
  (define q1 (q #f #\H #\e #\l #\o))
  (define q2 (q #f #\H #\e #\l #\o))
  (define q3 (q #f #\H #\e #\l))
  (check-true (equal? q1 q1))
  (check-true (equal? q1 q2))
  (check-false (equal? q1 q3))
  (define q4 (struct-copy quad q1
                          [draw (λ (q surface) (display "foo" surface))]))
  (check-equal? (with-output-to-string (λ () (draw q4))) "foo"))