(require (lib "url.ss" "net")
         (lib "pregexp.ss")
         (lib "xml.ss" "xml")
         (all-except (lib "html.ss" "html") object? make-object)
         (lib "mred.ss" "mred")
         (lib "class.ss"))

;; ======================================================================
;; THIS READS IN WORDS FROM A WEB PAGE

; string -> listof string
(define (words-from url-str)
  (let ((html (read-html-as-xml (get-pure-port (string->url url-str)))))
    (words html)))

; words : listof Content -> listof string
(define (words xml)
  (define (w/i x)
    (cond
      [(string? x) (string->words x)]
      [(pair? x) (apply append (map w/i (cddr x)))]
      [else '()]))
  (apply append (map (lambda (x) (w/i (xml->xexpr x))) xml)))

(define (string->words str) 
  (let ((words (pregexp-split "\\W+" str)))
    (if (and (pair? words) (string=? (car words) ""))
        '()
        words)))

;; ======================================================================
;; THIS IS THE GUI

(define magnet-snip%
  (class* string-snip% ()
    
    (init-field 
     string
     (top-margin 5)
     (left-margin 5)
     (bottom-margin 5)
     (right-margin 5)
     (brush #f))
    
    ;; ======================================================================
    ;; BOX DRAWING
    
    (rename (super-draw draw))
    (define/override (draw dc x y left top right bottom dx dy draw-caret)
      (let ((old-brush (send dc get-brush)))
        (when brush (send dc set-brush brush))
        (let-values ([(width height descent space) (send dc get-text-extent string)])
          (send dc draw-rectangle x y (+ left-margin width right-margin) (+ top-margin height bottom-margin)))
        (super-draw dc (+ x left-margin) (+ y right-margin) left top right bottom dx dy draw-caret)
        (when brush (send dc set-brush old-brush))))
    
    (rename (super-get-extent get-extent))
    (define/override (get-extent dc x y w h descent space lspace rspace)
      (super-get-extent dc x y w h descent space lspace rspace)
      (when w (set-box! w (+ (unbox w) left-margin right-margin)))
      (when h (set-box! h (+ (unbox h) top-margin bottom-margin))))
    
    (super-instantiate (string))))

(define magnet-pasteboard% 
  (class* pasteboard% ()
    
    (rename (super-on-select on-select))
    (inherit set-before)
    (inherit set-after)
    (define/override (after-select snip on?)
      
      (super-on-select snip on?)
      (when on? (set-before snip #f)))
    
    (super-new)))

(define white (instantiate color% (255 255 255)))
(define my-brush (instantiate brush% (white 'solid)))
(define (magnet w) (new magnet-snip% (string w) (brush my-brush)))

(define some-words (words-from "http://people.cs.uchicago.edu/~jacobm/"))

(define (add-words-callback . args)
  (let ([url (send url-field get-value)]
        [wbox (box 0)]
        [hbox (box 0)])
    (send pb get-view-size wbox hbox)
    (let ([width (inexact->exact (unbox wbox))]
          [height (inexact->exact (unbox hbox))])
      (send pb begin-edit-sequence)
      (for-each (lambda (str) (send pb insert (magnet str) #f (random width) (random height))) 
                (words-from url))
      (send pb end-edit-sequence))))

(define f (new frame% (label "Magnetic Poetry!") (height 500) (width 500)))
(define buttons (new horizontal-panel% (parent f) (style '(border)) (stretchable-width #t) (stretchable-height #f)))
(define url-field (new text-field% (label "URL: ") (parent buttons) (callback void)))
(define go-button (new button% (label "Load") (parent buttons) (callback add-words-callback)))
(new button% (label "Clear") (parent buttons) (callback (lambda (b e) (send pb erase))))
(new button% (label "Print") (parent buttons) (callback (lambda (b e) (send pb print))))
(define c (new editor-canvas% (parent f)))
(define pb (new magnet-pasteboard%))
(send c set-editor pb)
(send f show #t)