#lang scheme/base
; Modified 1/19/2005 to be compatible with new image.ss contracts.
; Modified 2/16/2005 to include stuff from world.ss as well as image.ss
; Modified 2/17/2005 to provide on-update-event (which requires overriding a few
; functions from world.ss)
; Modified 5/20/2005 to rename on-update-event as on-redraw-event, and
; handle pinholes more consistently in image-beside and image-above.
; Modified 1/26/2006 to remove the functions I was replacing in image.ss
; (since image.ss now does things the way I wanted) and
; to remove my tweaked copy of world.ss (since world.ss now does things the
; way I wanted).
; Modified 7/12/2006 to allow image-beside and image-above to take variable numbers of arguments.
; Modified 7/26/2006 to add image-beside-align-top, image-beside-align-bottom, image-above-align-left, and image-above-align-right.
; Modified 12/17/2007 to add crop-top, crop-bottom, crop-left, crop-right.  Also utility functions slice-pic and unslice-pic.
; Modified 12/26/2007 to provide all-from image.ss, so we never have to mention image.ss at all.
; Modified 8/15/2008 to add image-above-align-center and image-beside-align-center.
; Modified 10/28/2008 to use provide/contract (and 4.x-style module specs, rather than (lib blah blah))
; Modified again 10/28/2008 to do more user-friendly "check-arg"-style checking instead.
; Modified 1/3/2009 to fix bugs in crop-* and unslice-pic related to zero-sized images.
; Modified 7/9/2009 for compatibility with DrScheme 4.2
; Modified 10/19/2009 for compatibility with DrScheme 4.2.2: image? is now in htdp/image, so it doesn't need to be required from htdp/advanced.
; Modified 1/12/2010: renamed image-above et al to above et al, image-beside et al to beside et al.
;   place-image and scene+line are now defined in sb-universe, so they don't need to be here.
; Modified 2/10/2010: replaced color-list with alpha-color-list to fix a transparency bug.

  (require
   scheme/list ; foldl
   ; scheme/contract
   htdp/image
   lang/error
   )
  ; (require (only-in lang/htdp-advanced image?))

  (provide
   above above-align-right above-align-left above-align-center
   beside beside-align-top beside-align-bottom beside-align-center
   reflect-vert reflect-horiz reflect-main-diag reflect-other-diag
   rotate-cw rotate-ccw rotate-180
   show-pinhole
   crop-top crop-bottom crop-left crop-right)
;  (provide/contract
;   (above (->* (image? image?) () #:rest (listof image?) image?))
;   (above-align-right (->* (image? image?) () #:rest (listof image?) image?))
;   (above-align-left (->* (image? image?) () #:rest (listof image?) image?))
;   (above-align-center (->* (image? image?) () #:rest (listof image?) image?))
;   (beside (->* (image? image?) () #:rest (listof image?) image?))
;   (beside-align-top (->* (image? image?) () #:rest (listof image?) image?))
;   (beside-align-bottom (->* (image? image?) () #:rest (listof image?) image?))
;   (beside-align-center (->* (image? image?) () #:rest (listof image?) image?))
;   (reflect-vert (-> image? image?))
;   (reflect-horiz (-> image? image?))
;   (reflect-main-diag (-> image? image?))
;   (reflect-other-diag (-> image? image?))
;   (rotate-cw (-> image? image?))
;   (rotate-ccw (-> image? image?))
;   (rotate-180 (-> image? image?))
;;           rectangle
;;           circle
;;           ellipse
;;           triangle
;   (show-pinhole (-> image? image?))
;;            (all-from (lib "image.ss" "htdp"))
;   (crop-top (-> image? number? image?))
;   (crop-bottom (-> image? number? image?))
;   (crop-left (-> image? number? image?))
;   (crop-right (-> image? number? image?))
;           )

  (provide (all-from-out htdp/image))
  
  
  ; Added functions to image.ss
  
  ; image-translate : image int int => image
  (define (image-translate image dx dy)
    (overlay/xy (rectangle (+ (image-width image) dx)
                           (+ (image-height image) dy)
                           'solid
                           'white)
                dx
                dy 
                image))
  
  
  ; pinhole-to-bottom : image -> number
  (define (pinhole-to-bottom img)
    (- (image-height img) (pinhole-y img)))
  ; pinhole-to-top : image -> number
  (define (pinhole-to-top img)
    (pinhole-y img))
  ; pinhole-to-left : image -> number
  (define (pinhole-to-left img)
    (pinhole-x  img))
  ; pinhole-to-right : image -> number
  (define (pinhole-to-right img)
    (- (image-width img) (pinhole-x img)))
  
; concat-vert : image image => image
  (define (concat-vert under over)
    (let [[dy (+ (pinhole-to-bottom over) (pinhole-to-top under))]]
      (move-pinhole
       (overlay/xy over 0 (round (+ (pinhole-to-bottom over) (pinhole-to-top under))) under)
       0 (round (/ dy 2)))))

  ;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
  (if (and (pair? other-message) (string? (car other-message)))
      (check-arg tag (image? i) (car other-message) rank i)
      (check-arg tag (image? i) "image" rank i)))

(define numbered-arg-error "expected <~a> as argument number ~a, given: ~e")

; check-numbered-arg : sym bool str posint TST -> void
(define (check-numbered-arg pname condition expected arg-posn given)
  (unless condition (error pname numbered-arg-error expected arg-posn given)))

; check-all: sym (any -> boolean) str list -> void or error
(define (check-all tag test? expected args)
  (check-all0 tag test? expected args 1))
(define (check-all0 tag test? expected args count)
  (cond [(null? args) (void)]
        [(cons? args)
         (check-numbered-arg tag (test? (car args)) expected count (car args))
         (check-all0 tag test? expected (cdr args) (add1 count))]))
(define (check-all-images tag args)
  (check-all tag image? "image" args))
    
; above : image image ... -> image
  (define (above . images)
    (check-all-images 'above images)
    (cond [(null? images) (error 'above "Expected two or more images; given 0")]
          [(null? (cdr images)) (error 'above "Expected two or more images; given 1")]
          [else (foldl concat-vert (car images) (cdr images))]))

; above-align-right : image image ... -> image
  (define (above-align-right . images)
    (check-all-images 'above-align-right images)
    (apply above
           (map (lambda (img)
                  (move-pinhole img (pinhole-to-right img) 0))
                images)))
  
; above-align-left : image image ... -> image
  (define (above-align-left . images)
    (check-all-images 'above-align-left images)
    (apply above
           (map (lambda (img)
                  (move-pinhole img (- (pinhole-to-left img)) 0))
                images)))
  
  
  ; concat-horiz : image image => image
  (define (concat-horiz right left)
    (let [[dx (+ (pinhole-to-right left) (pinhole-to-left right))]]
      (move-pinhole
       (overlay/xy left dx 0 right)
       (round (/ dx 2)) 0)))

; beside : image image ... => image
  (define  (beside . images)
    (check-all-images 'beside images)
    (cond [(null? images) (error 'beside "Expected two or more images; given 0")]
          [(null? (cdr images)) (error 'beside "Expected two or more images; given 1")]
          [else (foldl concat-horiz (car images) (cdr images))]))
; beside-align-top : image image ... -> image
  (define (beside-align-top . images)
    (check-all-images 'beside-align-top images)
    (apply beside
           (map (lambda (img)
                  (move-pinhole img 0 (- (pinhole-to-top img))))
                images)))
  
; beside-align-bottom : image image ... -> image
  (define (beside-align-bottom . images)
    (check-all-images 'beside-align-bottom images)
    (apply beside
           (map (lambda (img)
                  (move-pinhole img 0 (pinhole-to-bottom img)))
                images)))

  ; center-pinhole : image -> image
  (define (center-pinhole img)
    (put-pinhole img
                 (quotient (image-width img) 2)
                 (quotient (image-height img) 2)))
  
  ; beside-align-center : image image ... -> image
  (define (beside-align-center . images)
    (check-all-images 'beside-align-center images)
    (apply beside
           (map center-pinhole images)))
  
  ; above-align-center : image image ... -> image
  (define (above-align-center . images)
    (check-all-images 'above-align-center images)
    (apply above
           (map center-pinhole images)))
  
  ; show-pinhole : image -> image
  ; assumes the image is not solid black
  (define (show-pinhole img)
    (check-image 'show-pinhole img "first")
    (overlay img (circle 2 "solid" "black")))
;  "Examples of show-pinhole:"
;  (show-pinhole (rectangle 50 30 "solid" "blue"))
;  "should be a 50x30 blue rectangle with a black dot in the center"
  ; first-n : list n => list of length n (or less)
  (define (first-n L n)
    (cond [(null? L) '()]
          [(<= n 0) '()]
          [else (cons (car L)
                      (first-n (cdr L) (- n 1)))]))
  ;"Examples of first-n:"
  ;(first-n empty 2) "should be" empty
  ;(first-n (list 'a) 2) "should be" (list 'a)
  ;(first-n (list 'a 'b 'c) 2) "should be" (list 'a 'b)
  
  ; rest-n : list n => list of length n smaller (or 0)
  (define (rest-n L n)
    (cond [(null? L) '()]
          [(<= n 0) L]
          [else (rest-n (cdr L) (- n 1))]))
  ;"Examples of rest-n:"
  ;(rest-n empty 2) "should be" empty
  ;(rest-n (list 'a) 2) "should be" empty
  ;(rest-n (list 'a 'b 'c) 2) "should be" (list 'c)
  
  ; slice : list n => list-of-lists
  ; Assumes n divides the length of the list
  (define (slice L width)
    (cond [(null? L) '()]
          [else (cons (first-n L width)
                      (slice (rest-n L width) width))]))
  
  ;"Examples of slice:"
  ;(slice (list 1 2 3 4 5 6) 2) "should be" (list (list 1 2) (list 3 4) (list 5 6))
  
  ; slice-pic : image n -> list-of-lists
  (define (slice-pic picture)
    (slice (image->alpha-color-list picture)
           (image-width picture)))
  
  ; unslice : list-of-lists => list
  (define (unslice lists)
    (apply append lists))
  ;"Example of unslice:"
  ;(unslice (list (list 1 2) (list 3 4) (list 5))) "should be" (list 1 2 3 4 5)
  
  ; unslice-pic : list-of-lists width height phx phy -> image
  (define (unslice-pic pixels width height phx phy)
    (cond [(or (zero? width) (zero? height))
           (put-pinhole (rectangle width height 'solid 'white) phx phy)]
          [else (alpha-color-list->image
                 (unslice pixels)
                 width height phx phy)
                ]))
  
  ; reflect-horiz : image => image
  (define (reflect-horiz picture)
    (check-image 'reflect-horiz picture "first")
    (unslice-pic
     (map reverse
          (slice-pic picture))
     (image-width picture)
     (image-height picture)
     (pinhole-to-right picture)
     (pinhole-to-top picture)))
  

  ; natural-number? anything -> boolean
  (define (natural-number? x)
    (and (integer? x) (>= x 0)))
  
  ; crop-left : image number -> image
  ; deletes that many pixels from left edge of image
  (define (crop-left picture pixels)
    (check-image 'crop-left picture "first")
    (check-arg 'crop-left (natural-number? pixels) 'natural-number "second" pixels)
    (let* ((new-width (max 0 (- (image-width picture) pixels)))
           (new-phx (max 0 (- (pinhole-x picture) pixels)))
           (real-pixels (- (image-width picture) new-width)))
      (unslice-pic
       (map
        (lambda (row) (rest-n row real-pixels))
        (slice-pic picture))
       new-width
       (image-height picture)
       new-phx
       (pinhole-y picture))))
  
  ; crop-top : image number -> image
  ; deletes that many pixels from top edge of image
  (define (crop-top picture pixels)
    (check-image 'crop-top picture "first")
    (check-arg 'crop-top (natural-number? pixels) 'natural-number "second" pixels)
    (let* ((new-height (max 0 (- (image-height picture) pixels)))
           (new-phy (max 0 (- (pinhole-y picture) pixels)))
           (real-pixels (- (image-height picture) new-height)))
      (unslice-pic
       (rest-n
        (slice-pic picture)
        real-pixels)
       (image-width picture)
       new-height
       (pinhole-x picture)
       new-phy)))
  
  ; crop-right : image number -> image
  ; deletes that many pixels from right edge of image
  (define (crop-right picture pixels)
    (check-image 'crop-right picture "first")
    (check-arg 'crop-right (natural-number? pixels) 'natural-number "second" pixels)
    (let* ((new-width (max 0 (- (image-width picture) pixels)))
           (new-phx (min (pinhole-x picture) new-width)))
      (unslice-pic
       (map
        (lambda (row) (first-n row new-width))
        (slice-pic picture))
       new-width
       (image-height picture)
       new-phx
       (pinhole-y picture))))
  
  ; crop-bottom : image number -> image
  ; deletes that many pixels from bottom edge of image
  (define (crop-bottom picture pixels)
    (check-image 'crop-bottom picture "first")
    (check-arg 'crop-bottom (natural-number? pixels) 'natural-number "second" pixels)
    (let* ((new-height (max 0 (- (image-height picture) pixels)))
           (new-phy (min (pinhole-y picture) new-height)))
      (unslice-pic
       (first-n
        (slice-pic picture)
        new-height)
       (image-width picture)
       new-height
       (pinhole-x picture)
       new-phy)))
  
  ; reflect-vert : image => image
  (define (reflect-vert picture)
    (check-image 'reflect-vert picture "first")
    (unslice-pic
     (reverse 
      (slice-pic picture))
     (image-width picture)
     (image-height picture)
     (pinhole-to-left picture)
     (pinhole-to-bottom picture)))
  
  ; ncons-each : list => list-of-one-element-lists
  (define (ncons-each L)
    (map list L))
  ;"Examples of ncons-each:"
  ;(ncons-each empty) "should be" empty
  ;(ncons-each (list 'a)) "should be" (list (list 'a))
  ;(ncons-each (list 'a 'b)) "should be" (list (list 'a) (list 'b))
  
  ; transpose : list-of-lists => list-of-lists
  ; Assumes all lists are the same length
  ; Assumes there's at least one row and at least one column
  (define (transpose rows)
    (apply map (cons list rows)))
  ;"Exampls of transpose:"
  ;(transpose (list (list 'a))) "should be" (list (list 'a))
  ;(transpose (list (list 'a 'b))) "should be" (list (list 'a) (list 'b))
  ;(transpose (list (list 'a) (list 'b))) "should be" (list (list 'a 'b))
  ;(transpose (list (list 'a 'b) (list 'c 'd))) "should be" (list (list 'a 'c) (list 'b 'd))
  
  ; reflect-main-diag : image => image
  (define (reflect-main-diag picture)
    (check-image 'reflect-main-diag picture "first")
    (unslice-pic
     (transpose
      (slice-pic picture))
     (image-height picture)
     (image-width picture)
     (pinhole-y picture)
     (pinhole-x picture)))
  
  ; reflect-other-diag : image => image
  (define (reflect-other-diag picture)
    (check-image 'reflect-other-diag picture "first")
    ;  (reflect-vert
    ;   (reflect-main-diag
    ;    (reflect-vert picture))))
    (unslice-pic
     (reverse
      (transpose
       (reverse
        (slice-pic picture))))
     (image-height picture)
     (image-width picture)
     (pinhole-to-bottom picture)
     (pinhole-to-right picture)))
  
  ; The following should probably be rewritten to rotate around the pinhole....
  ; rotate-cw : image => image
  (define (rotate-cw picture)
    (check-image 'rotate-cw picture "first")
    ;  (reflect-main-diag (reflect-vert picture)))
    (unslice-pic
     (transpose
      (reverse
       (slice-pic picture)))
     (image-height picture)
     (image-width picture)
     (pinhole-to-bottom picture)
     (pinhole-to-left picture)))
  
  ; rotate-ccw : image => image
  ; Ditto.
  (define (rotate-ccw picture)
    (check-image 'rotate-ccw picture "first")
    ;  (reflect-vert (reflect-main-diag picture)))
    (unslice-pic
     (reverse
      (transpose
       (slice-pic picture)))
     (image-height picture)
     (image-width picture)
     (pinhole-to-top picture)
     (pinhole-to-right picture)))
  
  ; rotate-180 : image => image
  (define (rotate-180 picture)
    (check-image 'rotate-180 picture "first")
    ; (rotate-cw (rotate-cw picture))
    ; (reflect-vert (reflect-horiz picture))
    (unslice-pic
     (reverse
      (map reverse
           (slice-pic picture)))
     (image-width picture)
     (image-height picture)
     (pinhole-to-right picture)
     (pinhole-to-bottom picture)))