#lang racket

#|

File: teachpack/image.rkt
Author: Bill Turtle (wrturtle)

Provide a wrapper to the image.ss teachpack used by htdp.

NOTE WELL: Structures that this teachpack defines (images, pens, etc)
           SHOULD support "dot-style" field lookup. This functionality
           is provided in semantics/lookup, via the `pyret-do-lookup' function.

|#

(require (prefix-in img: 2htdp/image))
(require (for-syntax "../utilities.rkt"))
(require "../utilities.rkt")
(require "../semantics/wrap-prim.rkt")
(require (prefix-in img: (only-in lang/imageeq image=?)))

;; define sigs for this teachpack
(define image-color-sig (sig "image color" img:image-color?))
(define image-color-list-sig (sig "list of image colors" (listof img:image-color?)))
(define image-sig (sig "image" img:image?))
(define mode-sig  (sig "mode" img:mode?))
(define angle-sig (sig "angle" img:angle?))
(define pen-sig   (sig "pen" img:pen?))
(define pen-or-color-sig (sig "pen or color" (or/c img:image-color? img:pen?)))
(define pen-style-sig (sig "pen style" img:pen-style?))
(define pen-cap-sig (sig "pen cap" img:pen-cap?))
(define pen-join-sig (sig "pen join" img:pen-join?))
(define outline-string-sig (sig "the string \"outline\"" (lambda (x) (equal? x "outline"))))
(define font-size-sig (sig "integer between 1 and 255, inclusive" 
                           (and/c integer? (lambda (c) (<= 1 c 255)))))
(define face-sig (sig "string or False" (or/c string? #f)))
(define family-sig 
        (sig "font family string"
             (or/c "default" "decorative" "roman" "script" "swiss" "modern" "symbol" "system")))
(define style-sig (sig "style string" (or/c "normal" "italic" "slant")))
(define weight-sig (sig "weight string" (or/c "normal" "bold" "light")))
(define side-count-sig (sig "side count" img:side-count?))
(define step-count-sig (sig "step count" img:step-count?))
(define int>=2-sig (sig "integer >= 2" (and/c integer? (>=/c 2))))
(define real-valued-posn-list-sig (sig "list of real-valued posns" (listof img:real-valued-posn?)))
(define x-place-sig (sig "x-place" (or/c "left" "right" "middle" "center" "pinhole")))
(define y-place-sig (sig "y-place" (or/c "top" "bottom" "middle" "center" "baseline" "pinhole")))
(define color-spec-sig (sig "integer between 0 and 255 inclusive" 
                       (and/c integer? (lambda (c) (<= 0 c 255)))))
(define pen-width-sig (sig "real number between 0 and 255 inclusive"
                           (and/c real? (lambda (c) (<= 0 c 255)))))

;; Basic images
(wrap circle1 circle img:circle (exactly 3) (list nonnegative-sig mode-sig image-color-sig))
(wrap circle2 circle img:circle (exactly 3) (list nonnegative-sig outline-string-sig pen-or-color-sig))
(wrap circle 
      (lambda (x y z) 
        (if (equal? y "outline") 
            (circle2 x y z) 
            (circle1 x y z)))
      (exactly 3)
      (list any-sig any-sig any-sig))
(wrap ellipse1 ellipse img:ellipse (exactly 4) (list nonnegative-sig nonnegative-sig mode-sig image-color-sig))
(wrap ellipse2 ellipse img:ellipse (exactly 4) (list nonnegative-sig 
                                                     nonnegative-sig 
                                                     outline-string-sig 
                                                     pen-sig))
(wrap ellipse
      (lambda (x y z w)
        (if (equal? z "outline")
            (ellipse2 x y z w)
            (ellipse1 x y z w)))
      (exactly 4)
      (list any-sig any-sig any-sig any-sig))
(wrap line img:line (exactly 3) (list real-sig real-sig pen-or-color-sig))
(wrap add_line img:add-line (exactly 6) (list image-sig
                                              real-sig
                                              real-sig
                                              real-sig
                                              real-sig
                                              pen-or-color-sig))
(wrap add_curve img:add-curve (exactly 10) (list image-sig
                                                 real-sig
                                                 real-sig
                                                 angle-sig
                                                 real-sig
                                                 real-sig
                                                 real-sig
                                                 angle-sig
                                                 real-sig
                                                 pen-or-color-sig))
(wrap text img:text (exactly 3) (list string-sig font-size-sig image-color-sig))
(wrap text_font 
      (lambda (a b c d e f g h)
        (img:text/font a b c d (string->symbol e) (string->symbol f) (string->symbol g) h))
      (exactly 8) 
      (list string-sig font-size-sig image-color-sig face-sig family-sig style-sig weight-sig any-sig))
(define empty_image img:empty-image)



(provide circle ellipse line add_line add_curve text text_font empty_image)

;; Polygons
(define-syntax wrap-outline
  (syntax-rules ()
    [(_ name function-to-use num-nonnegatives)
     (wrap-outline name function-to-use num-nonnegatives (make-list num-nonnegatives nonnegative-sig))]
    [(_ name function-to-use num-nonnegatives siglist)
     (begin
       (define first-option (list mode-sig image-color-sig))
       (define second-option (list outline-string-sig pen-or-color-sig))
       (wrap name1 name function-to-use (exactly (+ num-nonnegatives 2)) (append siglist first-option))
       (wrap name2 name function-to-use (exactly (+ num-nonnegatives 2)) (append siglist second-option))
       (wrap name
             (lambda args
               (let ([test-arg (list-ref args num-nonnegatives)])
                 (if (equal? test-arg "outline")
                     (apply name2 args)
                     (apply name1 args))))
             (exactly (+ num-nonnegatives 2))
             (make-list (+ num-nonnegatives 2) any-sig))
       (void))]))


(wrap-outline triangle img:triangle 1)
(wrap-outline right_triangle img:right-triangle 2)
(wrap-outline isosceles_triangle img:isosceles-triangle 2 (list nonnegative-sig angle-sig))
(wrap-outline triangle_sss img:triangle/sss 3)
(wrap-outline triangle_ass img:triangle/ass 3 (list angle-sig nonnegative-sig nonnegative-sig))
(wrap-outline triangle_sas img:triangle/sas 3 (list nonnegative-sig angle-sig nonnegative-sig))
(wrap-outline triangle_ssa img:triangle/ssa 3 (list nonnegative-sig nonnegative-sig angle-sig))
(wrap-outline triangle_aas img:triangle/aas 3 (list angle-sig angle-sig nonnegative-sig))
(wrap-outline triangle_asa img:triangle/asa 3 (list angle-sig nonnegative-sig angle-sig))
(wrap-outline triangle_saa img:triangle/saa 3 (list nonnegative-sig angle-sig angle-sig))
(wrap-outline square img:square 1)
(wrap-outline rectangle img:rectangle 2)
(wrap-outline rhombus img:rhombus 2 (list nonnegative-sig angle-sig))
(wrap-outline star img:star 1)
(wrap-outline star_polygon img:star-polygon 3 (list nonnegative-sig side-count-sig step-count-sig))
(wrap-outline radial_star img:radial-star 3 (list int>=2-sig nonnegative-sig nonnegative-sig))
(wrap-outline regular_polygon img:regular-polygon 2 (list nonnegative-sig side-count-sig))
(wrap-outline polygon img:polygon 1 (list real-valued-posn-list-sig))

(provide triangle right_triangle isosceles_triangle
         triangle_sss triangle_ass triangle_sas
         triangle_ssa triangle_aas triangle_asa
         triangle_saa square rectangle rhombus star
         star_polygon radial_star regular_polygon polygon)

;; Overlaying images
(wrap overlay img:overlay (at-least 2) (list image-sig image-sig))
(wrap overlay_align img:overlay/align (at-least 4) (list x-place-sig
                                                         y-place-sig
                                                         image-sig
                                                         image-sig))
(wrap overlay_offset img:overlay/offset (exactly 4) (list image-sig real-sig real-sig image-sig))
(wrap overlay_align_offset img:overlay/align/offset (exactly 6) (list x-place-sig
                                                                      y-place-sig
                                                                      image-sig
                                                                      real-sig
                                                                      real-sig
                                                                      image-sig))
(wrap overlay_xy img:overlay/xy (exactly 4) (list image-sig real-sig real-sig image-sig))
(wrap underlay img:underlay (at-least 2) (list image-sig image-sig image-sig))
(wrap underlay_align img:underlay/align (at-least 4) (list x-place-sig
                                                           y-place-sig
                                                           image-sig
                                                           image-sig))
(wrap underlay_offset img:underlay/offset (exactly 4) (list image-sig
                                                            real-sig
                                                            real-sig
                                                            image-sig))
(wrap underlay_align_offset img:underlay/align/offset (exactly 6) (list x-place-sig
                                                                        y-place-sig
                                                                        image-sig
                                                                        real-sig
                                                                        real-sig
                                                                        image-sig))
(wrap underlay_xy img:underlay/xy (exactly 4) (list image-sig real-sig real-sig image-sig))
(wrap beside img:beside (at-least 2) (list image-sig image-sig image-sig))
(wrap beside_align img:beside/align (at-least 3) (list y-place-sig image-sig image-sig))
(wrap above img:above (at-least 2) (list image-sig image-sig))
(wrap above_align img:above/align (at-least 3) (list x-place-sig image-sig image-sig))

(provide overlay overlay_align overlay_offset overlay_align_offset
         underlay underlay_align underlay_offset underlay_align_offset underlay_xy
         beside beside_align
         above above_align)

;; Placing images & scenes
(wrap empty_scene1 img:empty-scene (at-least 2) (list nonnegative-sig nonnegative-sig))
(wrap empty_scene2 img:empty-scene (at-most 3) (list nonnegative-sig nonnegative-sig))
(wrap empty_scene 
      ; this is probably not the best way to get "polymorphic arity" (i.e., 2 or 3)
      (case-lambda [(x y) (empty_scene1 x y)]
                   [(x y z) (empty_scene2 x y z)]
                   [() (empty_scene1)]
                   [(x) (empty_scene1)]
                   [args (apply empty_scene2 args)])
      (variable)
      (list any-sig))
(wrap place_image img:place-image (exactly 4) (list image-sig real-sig real-sig image-sig))
(wrap place_image_align img:place-image/align (exactly 5) (list image-sig
                                                                real-sig
                                                                real-sig
                                                                x-place-sig
                                                                y-place-sig
                                                                image-sig))
(wrap scene_plus_line
      img:scene+line
      (exactly 6)
      (list image-sig real-sig real-sig real-sig real-sig pen-or-color-sig))
(wrap scene_plus_curve img:scene+curve (exactly 10) (list image-sig 
                                                          real-sig 
                                                          real-sig 
                                                          angle-sig 
                                                          real-sig 
                                                          real-sig 
                                                          real-sig 
                                                          angle-sig 
                                                          real-sig 
                                                          image-color-sig))
(provide empty_scene place_image place_image_align scene_plus_line scene_plus_curve)

;; Rotating, scaling, flipping, cropping, and framing images
(wrap rotate img:rotate (exactly 2) (list angle-sig image-sig))
(wrap scale img:scale (exactly 2) (list real-positive-sig image-sig))
(wrap scale_xy img:scale/xy (exactly 3) (list real-positive-sig real-positive-sig image-sig))
(wrap flip_horizontal img:flip-horizontal (exactly 1) (list image-sig))
(wrap flip_vertical img:flip-vertical (exactly 1) (list image-sig))
(wrap crop img:crop (exactly 5) (list real-sig real-sig nonnegative-sig nonnegative-sig image-sig))
(wrap frame img:frame (exactly 1) (list image-sig))

(provide rotate scale scale_xy flip_horizontal flip_vertical crop frame)

;; Bitmaps
(wrap bitmap_url img:bitmap/url (exactly 1) (list string-sig))
(wrap bitmap_file img:bitmap/file (exactly 1) (list string-sig))
(wrap image_to_color_list img:image->color-list (exactly 1) (list image-sig))
(wrap color_list_to_bitmap img:color-list->bitmap (exactly 3) (list image-color-list-sig
                                                                    nonnegative-sig
                                                                    nonnegative-sig))
(define freeze img:freeze)
(provide (rename-out [img:bitmap bitmap])
         bitmap_url 
         bitmap_file
         image_to_color_list
         color_list_to_bitmap
         freeze)

;; Image properties
(wrap image_width img:image-width (exactly 1) (list image-sig))
(wrap image_height img:image-height (exactly 1) (list image-sig))
(wrap image_baseline img:image-baseline (exactly 1) (list image-sig))

(provide image_width image_height image_baseline)

;; Image predicates
(wrap is_image img:image? (exactly 1) (list any-sig))
(wrap is_mode img:mode? (exactly 1) (list any-sig))
(wrap is_image_color img:image-color? (exactly 1) (list any-sig))
(wrap color1 img:color (at-least 3) (list color-spec-sig
                                          color-spec-sig
                                          color-spec-sig))
(wrap color2 img:color (at-most 4) (list color-spec-sig
                                         color-spec-sig
                                         color-spec-sig
                                         color-spec-sig))
(wrap color 
      (lambda args
        (if (<= (length args) 3)
            (apply color1 args)
            (apply color2 args)))
      (variable)
      (list any-sig))
(wrap is_color img:color? (exactly 1) (list any-sig))
(wrap is_x_place img:x-place? (exactly 1) (list any-sig))
(wrap is_y_place img:y-place? (exactly 1) (list any-sig))
(wrap is_angle img:angle? (exactly 1) (list any-sig))
(wrap is_side_count img:side-count? (exactly 1) (list any-sig))
(wrap is_step_count img:step-count? (exactly 1) (list any-sig))
(wrap is_real_valued_posn img:real-valued-posn? (exactly 1) (list any-sig))
(wrap pen img:make-pen (exactly 5) (list image-color-sig
                                         pen-width-sig
                                         pen-style-sig
                                         pen-cap-sig
                                         pen-join-sig))
(wrap is_pen img:pen? (exactly 1) (list any-sig))
(wrap is_pen_style img:pen-style? (exactly 1) (list any-sig))
(wrap is_pen_cap img:pen-cap? (exactly 1) (list any-sig))
(wrap is_pen_join img:pen-join? (exactly 1) (list any-sig))

(provide is_image is_mode is_image_color color is_color
         is_x_place is_y_place is_angle is_side_count is_step_count is_real_valued_posn
         pen is_pen is_pen_style is_pen_cap is_pen_join)

;; equality testing
(wrap image_equal img:image=? (at-least 2) (list image-sig image-sig))
(provide image_equal)

;; Pinholes
(wrap center_pinhole img:center-pinhole (exactly 1) (list image-sig))
(wrap put_pinhole img:put-pinhole (exactly 3) (list integer-sig integer-sig image-sig))
(wrap pinhole_x img:pinhole-x (exactly 1) (list image-sig))
(wrap pinhole_y img:pinhole-y (exactly 1) (list image-sig))
(wrap clear_pinhole img:clear-pinhole (exactly 1) (list image-sig))
(wrap overlay_pinhole img:overlay/pinhole (at-least 2) (list image-sig image-sig))
(wrap underlay_pinhole img:underlay/pinhole (at-least 2) (list image-sig image-sig))

(provide center_pinhole put_pinhole pinhole_x pinhole_y clear_pinhole overlay_pinhole underlay_pinhole)
 
;; Exporting images to disk
(wrap save_image img:save-image (exactly 2) (list image-sig string-sig))
(wrap save_scaled_image img:save-image (exactly 4) (list image-sig
                                                         image-sig
                                                         nonnegative-sig
                                                         nonnegative-sig))
(wrap save_svg_image img:save-svg-image (exactly 2) (list image-sig string-sig))
(wrap save_scaled_svg_image img:save-svg-image (exactly 4) (list image-sig
                                                                 string-sig
                                                                 nonnegative-sig
                                                                 nonnegative-sig))

(provide save_image save_scaled_image
         save_svg_image save_scaled_svg_image)