#lang racket/base

; Vector graphic primitives
; Those primitives are used to build vector images and export them into svg files
(require
  racket/generic
  racket/string
  racket/math
  "color.rkt")

(provide
  vectorial->sxml-svg
  ; Point
  point point? point-x point-y
  ; Style
  style
  ; Transformations
  translate scale rotate
  ; Attributes
  attributes
  ; Attributes shortcuts
  at-transforms at-translate at-rotate
  at-fill-color
  ; Containers
  vector-image script group
  ; Basic shapes
  text circle ellipse rectangle polygon path
  ; Path movements
  move-to line-to quadratic-to cubic-to
  smooth-quadratic-to smooth-cubic-to arc-to
  close-path
  ; Complex shapes
  star
  )

; A vectorial is an entity that can be converted to a sxml-svg
(define-generics vectorial
  (vectorial->sxml-svg vectorial))

; like number->string, but forces the display to an inexact number
(define (real->string n)
  (number->string (exact->inexact n)))

; Note: all the structures are prefixed with s- to allow a broader syntax for constructors
; Point structure
(struct s-point
  (x ; Number
   y) ; Number
  #:transparent
  #:methods gen:vectorial
  ((define (vectorial->sxml-svg p)
    (string-append (real->string (s-point-x p)) "," (real->string (s-point-y p))))))

; Exported functions
(define (point [x 0] [y 0]) (s-point x y))
(define point? s-point?)
(define point-x s-point-x)
(define point-y s-point-y)

; Styles applicable to a shape
(struct s-style
  (fill-color ; color
   stroke-color ; color
   stroke-width ; number
   font-size ; number
   font-family ; string
   visible?) ; boolean
  #:methods gen:vectorial
  ((define (vectorial->sxml-svg s)
    (string-append
      (if (s-style-fill-color s)
          (string-append "fill:" (css-value (s-style-fill-color s)) ";")
          "")
      (if (s-style-stroke-color s)
          (string-append "stroke:" (css-value (s-style-stroke-color s)) ";")
          "")
      (if (s-style-stroke-width s)
          (string-append "stroke-width:" (real->string (s-style-stroke-width s)) ";")
          "")
      (if (s-style-font-size s)
          (string-append "font-size:" (real->string (s-style-font-size s)) ";")
          "")
      (if (s-style-font-family s)
          (string-append "font-family:" (s-style-font-family s) ";")
          "")
      (if (not (s-style-visible? s))
          "display:none;"
          "")
      ))))

; Exported functions
; Main constructor
(define (style
          #:fill-color [fill-color #f]
          #:stroke-color [stroke-color #f]
          #:stroke-width [stroke-width #f]
          #:font-size [font-size #f]
          #:font-family [font-family #f]
          #:visible? [visible? #t])
  (s-style fill-color stroke-color stroke-width font-size font-family visible?))

; Transformations

; Translation
(struct s-translate
  (vector) ; Point
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg t)
    (string-append "translate(" (super:vectorial->sxml-svg (s-translate-vector t)) ")"))))

; Exported function
(define (translate [vec (point 0 0)])
  (s-translate vec))

; Scaling
(struct s-scale
  (factor) ; Number
  #:methods gen:vectorial
  ((define (vectorial->sxml-svg t)
    (string-append "scale(" (real->string (s-scale-factor t)) ")"))))

; Exported function
(define (scale [fact 1])
  (s-scale fact))

; Rotation
(struct s-rotate
  (angle ; Number
   center) ; Point
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg t)
    (string-append
      "rotate("
      (real->string (s-rotate-angle t))
      (if (s-rotate-center t)
          (string-append "," (super:vectorial->sxml-svg (s-rotate-center t)))
          "")
      ")"))))

; Exported function
(define (rotate [angle 0] [center #f])
  (s-rotate angle center))

; Attributes - common optional attributes for the other structures
(struct s-attributes
  (id ; String
   class ; String
   style ; Style
   transforms ; list of transforms
   on-focus-in ; String
   on-focus-out ; String
   on-activate ; String
   on-click ; String
   on-mouse-down ; String
   on-mouse-up ; String
   on-mouse-over ; String
   on-mouse-move ; String
   on-mouse-out) ; String
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg attr)
    (filter
      cadr
      `((id ,(s-attributes-id attr))
        (class ,(s-attributes-class attr))
        (style ,(and (s-attributes-style attr) (super:vectorial->sxml-svg (s-attributes-style attr))))
        (transform ,(and (not (null? (s-attributes-transforms attr)))
                        (string-join (map super:vectorial->sxml-svg (s-attributes-transforms attr)) " ")))
        (onfocusin ,(s-attributes-on-focus-in attr))
        (onfocusout ,(s-attributes-on-focus-out attr))
        (onactivate ,(s-attributes-on-activate attr))
        (onclick ,(s-attributes-on-click attr))
        (onmousedown ,(s-attributes-on-mouse-down attr))
        (onmouseup ,(s-attributes-on-mouse-up attr))
        (onmouseover ,(s-attributes-on-mouse-over attr))
        (onmousemove ,(s-attributes-on-mouse-move attr))
        (onmouseout ,(s-attributes-on-mouse-out attr))
      )))))

; Exported function
(define (attributes
          #:id [id #f]
          #:class [class #f]
          #:style [style #f]
          #:transforms [transforms '()]
          #:on-focus-in [on-focus-in #f]
          #:on-focus-out [on-focus-out #f]
          #:on-activate [on-activate #f]
          #:on-click [on-click #f]
          #:on-mouse-down [on-mouse-down #f]
          #:on-mouse-up [on-mouse-up #f]
          #:on-mouse-over [on-mouse-over #f]
          #:on-mouse-move [on-mouse-move #f]
          #:on-mouse-out [on-mouse-out #f]
          )
  (s-attributes
    id class style transforms
    on-focus-in on-focus-out on-activate on-click
    on-mouse-down on-mouse-up on-mouse-over
    on-mouse-move on-mouse-out))

; Shortcuts
; For transformations
(define (at-transforms . rest)
  (attributes #:transforms rest))
(define (at-translate vec)
  (attributes #:transforms (list (translate vec))))
(define (at-rotate angle center)
  (attributes #:transforms (list (rotate angle center))))
; For styles
(define (at-fill-color col)
  (attributes #:style (style #:fill-color col)))

; Containers

; Top-level
(struct s-vector-image
  (width ; number
   height ; number
   contents) ; list of containers
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg v)
    `(svg
      ( (width ,(real->string (s-vector-image-width v)))
        (height ,(real->string (s-vector-image-height v)))
        (version "1.1")
        (xmlns "http://www.w3.org/2000/svg"))
      ,@(map super:vectorial->sxml-svg (s-vector-image-contents v))))))

; Exported function
(define (vector-image
          #:width width
          #:height height
          . contents)
  (s-vector-image width height contents))

; Script - contains a list of strings defining the script
(struct s-script
  (contents) ; List of strings
  #:methods gen:vectorial
  ((define (vectorial->sxml-svg scr)
    `(script
      "// <![CDATA[\n"
      ,(string-join (s-script-contents scr) "\n")
      "\n// ]]>"))))

; Exported function
(define (script . contents)
  (s-script contents))

; Group - a non-top level container to group elements
(struct s-group
  (attributes ; Attributes
   contents) ; list of containers
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg gr)
      (if (null? (s-group-contents gr))
        ""
        `(g
          ,(super:vectorial->sxml-svg (s-group-attributes gr))
          ,@(map super:vectorial->sxml-svg (s-group-contents gr)))))))

; Exported function
(define (group
          #:attributes [attr (attributes)]
          . contents)
  (s-group attr contents))

; Shapes

; Text
(struct s-text
  (attributes ; Attributes
   top-left ; Point
   contents) ; List of strings
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg txt)
      (if (null? (s-text-contents txt))
        ""
        `(text
          ,(append
            `((x ,(real->string (point-x (s-text-top-left txt))))
              (y ,(real->string (point-y (s-text-top-left txt)))))
            (super:vectorial->sxml-svg (s-text-attributes txt)))
          ,(s-text-contents txt))))))

; Exported function
(define (text
          #:attributes [attr (attributes)]
          #:top-left [top-left (point)]
          . contents)
  (s-text
    attr
    top-left
    contents))

; Circle
(struct s-circle
  (attributes ; Attributes
   center ; Point
   radius) ; Number
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg c)
    `(circle
      ,(append
        `((cx ,(real->string (point-x (s-circle-center c))))
          (cy ,(real->string (point-y (s-circle-center c))))
          (r ,(real->string (s-circle-radius c))))
        (super:vectorial->sxml-svg (s-circle-attributes c)))))))

; Exported function
(define (circle
          #:attributes [attr (attributes)]
          #:center [center (point)]
          #:radius radius)
  (s-circle
    attr
    center
    radius))

; Ellipse - an ellipse is defined with a center and two radiuses
(struct s-ellipse
  (attributes ; Attributes
   center ; Center
   horizontal-radius ; Number
   vertical-radius) ; Number
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg e)
    `(ellipse
      ,(append
        `((cx ,(real->string (point-x (s-ellipse-center e))))
          (cy ,(real->string (point-y (s-ellipse-center e))))
          (rx ,(real->string (s-ellipse-horizontal-radius e)))
          (ry ,(real->string (s-ellipse-vertical-radius e))))
        (super:vectorial->sxml-svg (s-ellipse-attributes e)))))))

; Exported function
(define (ellipse
          #:attributes [attr (attributes)]
          #:center [center (point)]
          #:horizontal-radius horizontal-radius
          #:vertical-radius vertical-radius)
  (s-ellipse
    attr
    center
    horizontal-radius
    vertical-radius))

; Rectangle
(struct s-rectangle
  (attributes ; Attributes
   top-left ; Point
   width ; Number
   height) ; Number
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg r)
    `(rect
      ,(append
        `((x ,(real->string (point-x (s-rectangle-top-left r))))
          (y ,(real->string (point-y (s-rectangle-top-left r))))
          (width ,(real->string (s-rectangle-width r)))
          (height ,(real->string (s-rectangle-height r))))
        (super:vectorial->sxml-svg (s-rectangle-attributes r)))))))

; Exported function
(define (rectangle
          #:attributes [attr (attributes)]
          #:top-left [top-left (point)]
          #:width width
          #:height height)
  (s-rectangle
    attr
    top-left
    width
    height))

; Polygon - contains a list of points
(struct s-polygon
  (attributes ; Attributes
   points) ; list of points
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg pol)
    (if (null? (s-polygon-points pol))
      ""
      `(polygon
        ,(append
          `((points ,(string-join (map super:vectorial->sxml-svg (s-polygon-points pol)) " ")))
          (super:vectorial->sxml-svg (s-polygon-attributes pol))))))))

; Exported function
(define (polygon
          #:attributes [attr (attributes)]
          . points)
  (s-polygon
    attr
    points))

; Path - contains a list of movements
(struct s-path
  (attributes ; Attributes
   movements) ; list of movements
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg pth)
    (if (null? (s-path-movements pth))
      ""
      `(path
        ,(append
          `((d ,(string-join (map super:vectorial->sxml-svg (s-path-movements pth)) " ")))
          (super:vectorial->sxml-svg (s-path-attributes pth))))))))

; Exported function
(define (path
          #:attributes [attr (attributes)]
          . movements)
  (s-path
    attr
    movements))

; Path movements

; Common attributes
(struct s-path-movement
  (relative? ; boolean
   end-point)) ; point

; Move to
(struct s-move-to s-path-movement
  ()
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "m" "M")
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (move-to
          end-point
          #:relative [relative? #f])
  (s-move-to
    relative?
    end-point))

; Line to
(struct s-line-to s-path-movement
  ()
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "l" "L")
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (line-to
          end-point
          #:relative [relative? #f])
  (s-line-to
    relative?
    end-point))

; Quadratic curve
(struct s-quadratic-to s-path-movement
  (control-point) ; Point
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "q" "Q")
      " "
      (super:vectorial->sxml-svg (s-quadratic-to-control-point mv))
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (quadratic-to
          #:control control-point
          #:end end-point
          #:relative [relative? #f])
  (s-quadratic-to
    relative?
    end-point
    control-point))

; Cubic curve
(struct s-cubic-to s-path-movement
  (1st-control-point  ; Point
   2nd-control-point) ; Point
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "c" "C")
      " "
      (super:vectorial->sxml-svg (s-cubic-to-1st-control-point mv))
      " "
      (super:vectorial->sxml-svg (s-cubic-to-2nd-control-point mv))
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (cubic-to
          #:1st-control 1st-control-point
          #:2nd-control 2nd-control-point
          #:end end-point
          #:relative [relative? #f])
  (s-cubic-to
    relative?
    end-point
    1st-control-point
    2nd-control-point))

; Smooth quadratic curve
(struct s-smooth-quadratic-to s-path-movement
  ()
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "t" "T")
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (smooth-quadratic-to
          end-point
          #:relative [relative? #f])
  (s-line-to
    relative?
    end-point))

; Smooth cubic curve
(struct s-smooth-cubic-to s-path-movement
  (control-point) ; Point
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "s" "S")
      " "
      (super:vectorial->sxml-svg (s-smooth-cubic-to-control-point mv))
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (smooth-cubic-to
          #:control control-point
          #:end end-point
          #:relative [relative? #f])
  (s-smooth-cubic-to
    relative?
    end-point
    control-point))

; Arc to
(struct s-arc-to s-path-movement
  (radius-point ; Point
   x-axis-rotation ; Number
   large-arc? ; boolean
   sweep?) ; boolean
  #:methods gen:vectorial
  ((define/generic super:vectorial->sxml-svg vectorial->sxml-svg)
   (define (vectorial->sxml-svg mv)
    (string-append
      (if (s-path-movement-relative? mv) "a" "A")
      " "
      (super:vectorial->sxml-svg (s-arc-to-radius-point mv))
      " "
      (real->string (s-arc-to-x-axis-rotation mv))
      " "
      (if (s-arc-to-large-arc? mv) "1" "0")
      " "
      (if (s-arc-to-sweep? mv) "1" "0")
      " "
      (super:vectorial->sxml-svg (s-path-movement-end-point mv))))))

; Exported function
(define (arc-to
          #:radius-point radius-point
          #:x-axis-rotation x-axis-rotation
          #:large-arc? large-arc?
          #:sweep? sweep?
          #:end end-point
          #:relative [relative? #f])
  (s-arc-to
    relative?
    end-point
    radius-point
    x-axis-rotation
    large-arc?
    sweep?))

; Close path directive
(struct s-close-path
  ()
  #:methods gen:vectorial
  ((define (vectorial->sxml-svg mv) "Z")))

; Exported function
(define (close-path) (s-close-path))

; Complex shapes

; Star - build a star-like polygon
(define (star
          #:attributes [attr (attributes)]
          #:nb-points [nb-points 5]
          #:radius radius
          #:ratio [ratio (/ 1 (+ 1 (* 2 (cos (/ pi nb-points)))))]
          #:center center)
  (define radius-major radius)
  (define a (/ pi nb-points))
  (define radius-minor (* ratio radius-major))
  (define (on-circle r i)
    (point
      (+ (point-x center) (* r (cos (* a i))))
      (+ (point-y center) (* r (sin (* a i))))))
  (define (add-points lst i n)
    (if (>= i n)
        lst
        (add-points
          (append
            (list (on-circle radius-minor (+ 1 i))
                  (on-circle radius-major i))
            lst)
          (+ 2 i)
          n)))
  (apply polygon
    (add-points (list) 0 (* 2 nb-points))
    #:attributes attr))
