; Ali Faiz
; CS4451
; P1

;;; B-Spline
; This file needs to be run under a Scheme interpreter, preferably 
; a recent version of DrScheme. The program must be run in Advanced 
; Student mode with the draw.ss teachpack. The lecture slides were
; a source of information and help.

;;;;;;; Polygonal Coordinates

(define bigtriangle (list (make-posn 50 60) (make-posn 300 400)
                          (make-posn 50 400)))

(define rectangle (list (make-posn 50 100) (make-posn 50 300)
              (make-posn 200 300) (make-posn 200 100)))

(define random-shape (list (make-posn 50 100)(make-posn 100 130)
                           (make-posn 150 350)(make-posn 255 380) 
                           (make-posn 200 100)(make-posn 140 70)))

(define sharp-curve (list (make-posn 50 100) (make-posn 50 100) 
                          (make-posn 50 300) (make-posn 200 300) 
                          (make-posn 200 100)))

(define triangle1 (list (make-posn 50 60) (make-posn 200 200)
                       (make-posn 50 200)))
(define triangle2 (list (make-posn 250 300) (make-posn 400 440)
              (make-posn 250 440)))
(define triangle3 (list (make-posn 300 40) (make-posn 450 180)
              (make-posn 300 180)))

(define tri-surface (list triangle1 triangle2 triangle3))

;;;;;;;;;Methods for drawing
(define (make-canvas x y)
  (begin (start x y)))
         
(define (SHOW V)
  (show-clr 'blue V))

;;;;; show-clr: used to draw a polygon a certain color
(define (show-clr clr V)
  (local [
          (define (show-more col fst v)
            (cond [(null? (cdr v))
                   (draw-solid-line (car v) fst col)]
                  [else (begin
                          (draw-solid-line (car v) (cadr v) col)
                          (show-more col fst (cdr v)))]))
          ]
    (cond [(null? V) (print "Vertex array is null")]
          [else (show-more clr (car V) V)])))

;;;;;make-midpts: Used to create a list of midpoints given a
;;;;;;;;;;;;;;;;  list representing vertices, V.

(define (make-midpts V)
  (local [
          (define (mk-mid fst V newv)
            (cond [(null? (cdr V)) 
                   (append (list (find-midpt (car V) fst)) newv)]
                  [else (mk-mid fst (cdr V) 
                                (append newv (list 
                                              (find-midpt 
                                               (car V)(cadr V)))))]))
          ]
    (cond [(< (length V) 3) (print "Vertex array is too small.")]
          [else (mk-mid (car V) V null)])))

;;;;; find-midpt: The math guts of make-midpts
(define (find-midpt ps1 ps2)
  (make-posn (/ (+ (posn-x ps1) (posn-x ps2)) 2) 
             (/ (+ (posn-y ps1)(posn-y ps2)) 2)))
 
;;;;;interleaving: simple code for interleaving 2 lists
(define (interleaving m a)
  (cond [(null? m) a]
        [(null? a) m]
        [else (append (list (car m) (car a)) 
                      (interleaving (cdr m) (cdr a)))]))

;;;;;;;;BSPLINE specific functions
;;;;;;;;;;;Array "A" for Split&Tweak
;;;;;;;;;;;make-A: function used to create a list of vertices that are 
;;;;;;;;;;;;;;;;;; 1/4 closer to their neighbors than the original 
;;;;;;;;;;;;;;;;;; vertices, V.
(define (make-A V)
  (cond [(< (length V) 3) (print "Vertex array is too small.")]
        [else (mk-A (car V) (cdr V) V (car V) (cddr V) null)]))

(define (mk-A fst v ov prev nxt newpts)
  (cond [(null? v) null]
        [(null? nxt) (append (cons (find-1/4 prev (car v) fst) newpts)
                             (list (find-1/4 (car v) fst (cadr ov))))]
        [else (mk-A fst (cdr v) ov (car v) (cdr nxt) 
                    (append (list (find-1/4 prev (car v) (car nxt)))
                                            newpts))]))

;;;;; find-1/4: The math guts of mk-A
(define (find-1/4 prev curr nxt)
  (make-posn (+ (* (/ 1 8)(posn-x prev))(* (/ 1 8) (posn-x nxt))
                (* (/ 3 4) (posn-x curr)))
             (+ (* (/ 1 8) (posn-y prev))(* (/ 1 8) (posn-y nxt))
                (* (/ 3 4) (posn-y curr)))))

                   

(define (BSPLINE v)
  (if (null? v) null
      (interleaving (make-A v)(reverse (make-midpts v)))))


;;;;;;FOURPTS specific functions
;;;;;;;;;;;Array "A" for 4-point subdivision
;;;;;;;;;;;make-1/8: function used to create a list of vertices that are 
;;;;;;;;;;;;;;;;;; 1/8 farther from their midpoints than the original 
;;;;;;;;;;;;;;;;;; vertices, V.
(define (make-1/8 V)
  (cond [(< (length V) 3) (print "Vertex array is too small.")]
        [(= (length V) 3) (tri-A (car V) (cadr V) (caddr V))]
        [else (A-1/8 (car V) (cadr V) (caddr V) (cadddr V) 
                      (append (cdr(cdddr V)) V) (length V) null)]))

(define (A-1/8 fst sec thrd frth v cnt newpts)
  (cond [(null? v) newpts]
        [(= 1 cnt) (cons (find-1/8 (find-midpt sec thrd)
                                   (find-midpt fst frth))
                         newpts)]
        [else (A-1/8 sec thrd frth (car v) (cdr v) (- cnt 1)
                      (append newpts 
                              (list (find-1/8 
                                     (find-midpt sec thrd) 
                                     (find-midpt fst frth)))))]))

;;;;;; tri-A: for the special case where the polygon has three sides
(define (tri-A fst sec thrd)
  (append (list (find-1/8 (find-midpt fst sec) thrd)
                (find-1/8 (find-midpt sec thrd) fst)
                (find-1/8 (find-midpt thrd fst) sec))))
    
;;;;; find-1/8: The math guts of A-1/8
(define (find-1/8 mid midpr)
  (make-posn (+ (* (/ 1 8)(- (posn-x mid)(posn-x midpr)))
                (posn-x mid))
             (+ (* (/ 1 8)(- (posn-y mid)(posn-y midpr)))
                (posn-y mid))))

(define (FOURPTS v)
  (if (null? v) null
      (interleaving v (make-1/8 v))))

;;;;;;;;;;;;;SURFACES
;;;;Takes in a list of polygons represented by lists
(define (SHOW-SURFACE lop)
  (show-s-clr 'blue lop))

(define (show-s-clr clr lop)
  (cond [(null? lop) null]
        [else (begin (show-clr clr (car lop))
                     (show-s-clr clr (cdr lop)))]))


(define (SURFACE-BSPLINE lop)
  (cond [(null? lop) null]
        [else (curve-poly-spl 
               (link-side (curve-poly-spl lop null) null null null) 
               null)]))

(define (SURFACE-FOURPTS lop)
  (cond [(null? lop) null]
        [else (curve-poly-fr 
               (link-side (curve-poly-fr lop null) null null null) 
               null)]))

;;;;;; link-side: accomplishes 2nd part of surface mapping by creating
;;;;;;;;;;;;;;;;  control polygons from the B-spline curves derived 
;;;;;;;;;;;;;;;;  from the individual polygons in the plane.
;;;;;;;;;;;;;;;;  This is illustrated in red in the simulation
(define (link-side lop newpol newlst restlst)
  (cond [(and (null? lop)(null? restlst)) newlst]
        [(null? lop) (link-side restlst null 
                                (append newlst (list newpol )) null)] 
        [else (link-side (cdr lop) (append newpol (list (caar lop)))
                         newlst (app-cdar restlst (cdar lop)))]))

(define (app-cdar lst1 lst2)
  (if (null? lst2) lst1
             (append lst1 (list lst2))))

;;;;;;;;; curve-poly: converts all polygons into B-spline curves
(define (curve-poly-spl lop newlst)
  (cond [(null? lop) newlst]
        [else (curve-poly-spl (cdr lop)
                          (cons (BSPLINE (BSPLINE 
                                          (BSPLINE (BSPLINE (car lop)))))
                                          newlst))]))

(define (curve-poly-fr lop newlst)
  (cond [(null? lop) newlst]
        [else (curve-poly-fr (cdr lop)
                          (cons (FOURPTS (FOURPTS 
                                          (FOURPTS (FOURPTS (car lop)))))
                                          newlst))]))


;;;;;;;;; Simulations: 
;;;;;;;;;  Below are simulations that display the effectiveness of the
;;;;;;;;;  programs written above. They simply draw, in color the 
;;;;;;;;;  polygons outlined in the project description 
;;;;;;;;;  (i.e. 1 iteration of BSPLINE on a polygon) 
;;;;;;;;;  Below it is code that actually runs the simulations.

(define (bspline-sim v)
  (if (null? v) (print "Vertex array empty.")
      (begin 
        (make-canvas 500 500)
        (show-clr 'black v)
        (show-clr 'green (BSPLINE v))
        (show-clr 'red (BSPLINE (BSPLINE v)))
        (SHOW (BSPLINE (BSPLINE (BSPLINE (BSPLINE (BSPLINE v)))))))))

(define (fourpts-sim v)
  (if (null? v) (print "Vertex array is empty.")
      (begin 
        (make-canvas 500 500)
        (show-clr 'black v)
        (show-clr 'green (FOURPTS v))
        (show-clr 'red (FOURPTS (FOURPTS v)))
        (SHOW (FOURPTS (FOURPTS (FOURPTS (FOURPTS (FOURPTS v)))))))))

(define (surface-sim-bspl lov)
  (if (null? lov) (print "Vertex array is empty.")
      (begin 
        (make-canvas 500 500)
        (show-s-clr 'black lov)
        (show-s-clr 'green (curve-poly-spl lov null))
        (show-s-clr 'red (link-side 
                          (curve-poly-spl lov null) null null null))
        (SHOW-SURFACE (SURFACE-BSPLINE lov))
        (SHOW-SURFACE (link-side (SURFACE-BSPLINE lov) null null null)))))

(define (surface-sim-fourpt lov)
  (if (null? lov) (print "Vertex array is empty.")
      (begin 
        (make-canvas 500 500)
        (show-s-clr 'black lov)
        (show-s-clr 'green (curve-poly-spl lov null))
        (show-s-clr 'red (link-side 
                          (curve-poly-spl lov null) null null null))
        (SHOW-SURFACE (SURFACE-FOURPTS lov))
        (SHOW-SURFACE (link-side (SURFACE-FOURPTS lov) null null null)))))

;;;;;;;;; Simulations runners
(bspline-sim sharp-curve)
(bspline-sim bigtriangle)
(bspline-sim rectangle)
(bspline-sim random-shape)

(fourpts-sim bigtriangle)
(fourpts-sim rectangle)
(fourpts-sim random-shape)

(surface-sim-bspl tri-surface)
(surface-sim-fourpt tri-surface)