Function: strokes-fill-stroke

strokes-fill-stroke is a byte-compiled function defined in strokes.el.gz.

Signature

(strokes-fill-stroke UNFILLED-STROKE &optional FORCE)

Documentation

Fill in missing grid locations in the list of UNFILLED-STROKE.

If FORCE is non-nil, then fill the stroke even if it's strokes-click-p. NOTE: This is where the global variable strokes-last-stroke is set.

Source Code

;; Defined in /usr/src/emacs/lisp/strokes.el.gz
(defun strokes-fill-stroke (unfilled-stroke &optional force)
  "Fill in missing grid locations in the list of UNFILLED-STROKE.
If FORCE is non-nil, then fill the stroke even if it's `strokes-click-p'.
NOTE: This is where the global variable `strokes-last-stroke' is set."
  (setq strokes-last-stroke		; this is global
	(if (and (strokes-click-p unfilled-stroke)
		 (not force))
	    unfilled-stroke
	  (cl-loop
           for grid-locs on unfilled-stroke
           nconc (let* ((current (car grid-locs))
                        (current-is-a-point-p (consp current))
                        (next (cadr grid-locs))
                        (next-is-a-point-p (consp next))
                        (both-are-points-p (and current-is-a-point-p
                                                next-is-a-point-p))
                        (x1 (and current-is-a-point-p
                                 (car current)))
                        (y1 (and current-is-a-point-p
                                 (cdr current)))
                        (x2 (and next-is-a-point-p
                                 (car next)))
                        (y2 (and next-is-a-point-p
                                 (cdr next)))
                        (delta-x (and both-are-points-p
                                      (- x2 x1)))
                        (delta-y (and both-are-points-p
                                      (- y2 y1)))
                        (slope (and both-are-points-p
                                    (if (zerop delta-x)
                                        nil ; undefined vertical slope
                                      (/ (float delta-y)
                                         delta-x)))))
                   (cond ((not both-are-points-p)
                          (list current))
                         ((null slope)  ; undefined vertical slope
                          (if (>= delta-y 0)
                              (cl-loop for y from y1 below y2
                                       collect (cons x1 y))
                            (cl-loop for y from y1 above y2
                                     collect (cons x1 y))))
                         ((zerop slope) ; (= y1 y2)
                          (if (>= delta-x 0)
                              (cl-loop for x from x1 below x2
                                       collect (cons x y1))
                            (cl-loop for x from x1 above x2
                                     collect (cons x y1))))
                         ((>= (abs delta-x) (abs delta-y))
                          (if (> delta-x 0)
                              (cl-loop for x from x1 below x2
                                       collect (cons x
                                                     (+ y1
                                                        (round (* slope
                                                                  (- x x1))))))
                            (cl-loop for x from x1 above x2
                                     collect (cons x
                                                   (+ y1
                                                      (round (* slope
                                                                (- x x1))))))))
                         (t             ; (< (abs delta-x) (abs delta-y))
                          (if (> delta-y 0)
                              ;; FIXME: Reduce redundancy between branches.
                              (cl-loop for y from y1 below y2
                                       collect (cons (+ x1
                                                        (round (/ (- y y1)
                                                                  slope)))
                                                     y))
                            (cl-loop for y from y1 above y2
                                     collect (cons (+ x1
                                                      (round (/ (- y y1)
                                                                slope)))
                                                   y))))))))))