;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license.  By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;; 
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;; 
;;; Copyright 1995 by the Massachusetts Institute of Technology.  All
;;; rights reserved.  Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;; 
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.  By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;; 
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software.  Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;; 

;;; -*- Mode: LISP; Package: 2DG; Syntax: Common-Lisp; Base: 10. -*-
(in-package 2DG)

(export '(strings-to-line-segments edges-to-line-segments split-and-merge))

(defun STRINGS-TO-LINE-SEGMENTS (strings thresh)
  "Makes straight line approximations to strings of points.  A string is a 
   list of connected points.  This forms a line from the begining point of 
   the string to the end.  It then breaks this into 2 lines at the point where
   the string deviates most from the line.  This process continues recursively
   until the lines approximate the string to within a desired accuracy.
   Input: strings - Each string is a list of points.  Each point must be adjacent
          to the next.
          thresh - The maximum allowed distance from the string to any of the 
                   line segments.  When the lines don't approximate the string to
                   within thresh, the process stops.  2 is a reasonable value for
                   thresh."
  (loop for string in strings
	collecting
	  (break-line (copy-list string) (car (last string)) (length string) thresh) ))

(defun EDGES-TO-LINE-SEGMENTS (edge-array thresh)
  "This calls edge-image-strings with edge-array, and strings-to-line-segments with thresh."
  (flatten (strings-to-line-segments (edge-image-strings edge-array) thresh)))

(defun DIST-X-Y (dx dy) (sqrt (+ (* dx dx) (* dy dy))))

(defun DOT-X-Y (x1 x2 y1 y2) (+ (* x1 x2) (* y1 y2)))

(defun BREAK-LINE (line-list last-point length thresh)
  (when (= length 1)
    (return-from break-line nil) )
  (when (< length 3)
    (return-from break-line (list (make-line-segment (car line-list) last-point))) )
  (let* ((x0 (point-x (first line-list)))
	 (y0 (point-y (first line-list)))
	 (xn (point-x last-point))
	 (yn (point-y last-point))
	 e (max-e 0)
	 (line-1-length)
	 (line-1-end)
	 (dx (- xn x0))
	 (dy (- yn y0))
	 (d (dist-x-y dx dy))
	 (tan-x (/ dx d))
	 (tan-y (/ dy d))
	 (norm-x (- tan-y))
	 (norm-y tan-x) )
    (loop for point in (cdr line-list)
	  for line-end on (cdr line-list)
	  for line-length from 2
	  for p-dx = (- (point-x point) x0)
	  and p-dy = (- (point-y point) y0)
	  for tan-d = (dot-x-y tan-x p-dx tan-y p-dy)
	  do
      (cond
	((< tan-d 0) (setq e (dist-x-y p-dx p-dy)) )
	((> tan-d d)
	 (let ((p-dxn (- (point-x point) xn))
	       (p-dyn (- (point-y point) yn)) )
	   (setq e (dist-x-y p-dxn p-dyn)) ))
	(t (setq e (abs (dot-x-y norm-x p-dx norm-y p-dy)))) )
      (when (> e max-e)
	(setq line-1-length line-length
	      line-1-end line-end
	      max-e e )))
    (if (> max-e thresh)
	(let ((line-2 (cons (car line-1-end) (cdr line-1-end))))
	  (rplacd line-1-end nil)
	  (append (break-line line-list (car line-1-end) line-1-length thresh)
		  (break-line line-2 last-point (- length line-1-length -1) thresh) ))
	(list (make-line-segment (car line-list) last-point)) )))


;;; LINE SEGMENT STRING APPROXIMATION
;;; ----------------------------------------------------------------------

;;; SPLIT-AND-MERGE fits connected straight line segments to smooth
;;; string intervals such that the maximum perpendicular distance between
;;; the segment and the string is below a threshold.  It uses a recursive
;;; split (like TLP's version).

;;; The maximum pixel error allowed between a line and the string it is
;;; approximating.
(defvar *STRING-LINE-BREAK-MAX-ERR*)
(setq *STRING-LINE-BREAK-MAX-ERR* 2.0) ; 1.0)
;;; The maximum average pixel error allowed between a line and the string
;;; it is approximating.
(defvar *STRING-LINE-BREAK-MAX-AVE-ERR*)
(setq *STRING-LINE-BREAK-MAX-AVE-ERR* 0.6) ; .3)
;;; The minimum length of a line used to approximate a string.
(defvar *STRING-LINE-MIN-LENGTH*)
(setq *STRING-LINE-MIN-LENGTH* 5)
;;; The maximum pixel error allowed between a line and the string it is
;;; approximating.
(defvar *STRING-LINE-MERGE-MAX-ERR*)
(setq *STRING-LINE-MERGE-MAX-ERR* 3.0) ; 1.5)
;;; The maximum average pixel error allowed between a line and the string
;;; it is approximating.
(defvar *STRING-LINE-MERGE-MAX-AVE-ERR*)
(setq *STRING-LINE-MERGE-MAX-AVE-ERR* 1.2) ; 0.6)
;;; The maximum angle that can separate two lines we will try to merge.
(defvar *MAX-MERGE-ANGLE*)
(setq *MAX-MERGE-ANGLE* .1)

(defstruct (split-and-merge-line
	     :named
	     (:print-function (lambda (l stream &rest ignore)
				(format stream "#<S&L-LINE ~A ~A>"
					(split-and-merge-line-pt1 l)
					(split-and-merge-line-pt2 l)))))
  "Special line structure for split-and-merge routine.  It stores info about the line"
  pt1
  pt2
  index1
  index2
  length
  angle
  norm-x
  norm-y
  norm-dot)

(defun SPLIT-AND-MERGE (strings &optional
			(break-max-error *string-line-break-max-err*)
			(break-max-ave-error *string-line-break-max-ave-err*)
			(min-length *string-line-min-length*)
			(merge-max-error *string-line-merge-max-err*)
			(merge-max-ave-error *string-line-merge-max-ave-err*) )
    (loop ;; with len = (length strings)
	  for string in strings
	  for i upfrom 0
	  with line-res = nil
	  with string-res = nil
	  doing
      (multiple-value-bind (lines strings)
	  (string-to-lines string break-max-error break-max-ave-error min-length
			   merge-max-error merge-max-ave-error )
	(setf line-res (nconc lines line-res))
	(setf string-res (nconc strings string-res)))
	  finally (return (values line-res string-res))))

(defun STRING-TO-LINES (string break-max-error break-max-ave-error min-length
			merge-max-error merge-max-ave-error )
  (let* ((points (point-array-from-string string))
	 (lines (split-and-merge-break-line points 0 (1- (length points))
					    break-max-error break-max-ave-error min-length )))
    (when lines
      (setq lines (merge-lines lines points merge-max-error merge-max-ave-error)) )
    (loop for line in lines
	  collect (split-and-merge-to-segment line) into line-segments
	  collect (loop for i from (split-and-merge-line-index1 line) to (split-and-merge-line-index2 line)
			collecting
			  (aref points i))
	    into strings
	  finally (return (values line-segments strings)))))

(defun SPLIT-AND-MERGE-TO-SEGMENT (line)
  (make-line-segment (split-and-merge-line-pt1 line)
		     (split-and-merge-line-pt2 line)))

(defun POINT-ARRAY-FROM-STRING (c)
  (let ((a (make-array (list (length c)))))
    (loop for p in c
	  for i from 0
	  doing
      (setf (aref a i) p) )
    a ))

;;; END-I is included in the interval.
(defun SPLIT-AND-MERGE-BREAK-LINE (points start-i end-i max-error max-ave-error min-length)
  (when (>= (1+ (- end-i start-i)) min-length)
    (let ((line (make-line-from-points points start-i end-i)))
      (multiple-value-bind (max-err break-i ave-err) (find-line-max-error line points)
	(if (or (> max-err max-error) (> ave-err max-ave-error))
	    (append (split-and-merge-break-line points start-i break-i
				max-error max-ave-error min-length)
		    (split-and-merge-break-line points break-i end-i
				max-error max-ave-error min-length))
	    (list line) )))))

(defun MAKE-LINE-FROM-POINTS (points index-1 index-2)
  (let* ((point-1 (aref points index-1))
	 (point-2 (aref points index-2))
	 (x0 (point-x point-1))
	 (y0 (point-y point-1))
	 (xn (point-x point-2))
	 (yn (point-y point-2))
	 (dx (- xn x0))
	 (dy (- yn y0))
	 (d (dist-x-y dx dy))
	 (tan-x (/ dx d))
	 (tan-y (/ dy d))
	 (norm-x (- tan-y))
	 (norm-y tan-x) )
    (make-split-and-merge-line :pt1 point-1 :pt2 point-2 :index1 index-1 :index2 index-2
	                       :length d :angle (atan dy dx)
	                       :norm-x norm-x :norm-y norm-y
	                       :norm-dot (dot-x-y norm-x x0 norm-y y0) )))



;;; Finds the location of the pixel with maximum distance (error) from
;;; the line.  It returns the max error and information for breaking the
;;; line at the max error point, and the average error.
(defun FIND-LINE-MAX-ERROR (line points)
  (declare (values max-error max-error-i ave-error))
  (let* ((start-i (split-and-merge-line-index1 line))
	 (end-i   (split-and-merge-line-index2 line))
	 (x0 (point-x (split-and-merge-line-pt1 line)))
	 (y0 (point-y (split-and-merge-line-pt1 line)))
	 (xn (point-x (split-and-merge-line-pt2 line)))
	 (yn (point-y (split-and-merge-line-pt2 line)))
	 (d (dist-x-y (- xn x0) (- yn y0)))
	 e (max-e 0) (max-e-i start-i) (ave-e 0)
	 (norm-x (split-and-merge-line-norm-x line))
	 (norm-y (split-and-merge-line-norm-y line))
	 (tan-x norm-y)
	 (tan-y (- norm-x)) )
    (loop
      for i from start-i to end-i
      for point = (aref points i)
      for p-dx = (- (point-x point) x0)
      for p-dy = (- (point-y point) y0)
      for tan-d = (dot-x-y tan-x p-dx tan-y p-dy)
      doing
      (cond
	((< tan-d 0) (setq e (dist-x-y p-dx p-dy)) )
	((> tan-d d)
	 (let ((p-dxn (- (point-x point) xn))
	       (p-dyn (- (point-y point) yn)) )
	   (setq e (dist-x-y p-dxn p-dyn)) ))
	(t (setq e (abs (dot-x-y norm-x p-dx norm-y p-dy)))) )
      (incf ave-e e)
      (when (> e max-e) (setq max-e e max-e-i i)) )
    (setq ave-e (/ ave-e (1+ (- end-i start-i)))) 
    (values max-e max-e-i ave-e) ))



(defun MERGE-LINES (lines points max-error max-ave-error)
  (loop for first? in *FIRST-T-THEN-NIL*
    for prev-line = (if first? (first lines) (or merged-line line))
    for line in (rest lines)
    for merged-line = nil
    doing
    (when (< (abs-angle-difference (split-and-merge-line-angle line) (split-and-merge-line-angle prev-line)) *max-merge-angle*)
;      (format t "~&Trying merge... ")
      (setq merged-line
	    (make-line-from-points points (split-and-merge-line-index1 prev-line) (split-and-merge-line-index2 line)) )
      (multiple-value-bind (max-err ignore ave-err) (find-line-max-error merged-line points)
	(when (or (> max-err max-error) (> ave-err max-ave-error))
	  (setq merged-line nil)		;(format t "failed.")
	  )))
;    (when merged-line (format t "succeeded."))
    unless merged-line				; postpone collection until further merging
      collect prev-line into merged-lines	
    finally (return (nconc merged-lines (list prev-line)))) )

