;;; 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 '(edge-image-strings))

(defvar *FIRST-T-THEN-NIL*)
(setq *FIRST-T-THEN-NIL* (list t nil))
(rplacd (cdr *FIRST-T-THEN-NIL*) (cdr *FIRST-T-THEN-NIL*))
;;; This makes *FIRST-T-THEN-NIL* a list of (t nil nil nil nil ...)

(defun EDGE-IMAGE-STRINGS (edge-image)
  "Find connected strings of edge points in an image represented as a binary array.
   Strings are broken at junctions (when points have more than 
   two neighbors).
   Input: A binary array, with 1 where there is an edge, 0 where there isn't.
   Output: A list of strings.  Each string is a list of connected points, in order."
  (destructuring-bind (h w) (array-dimensions edge-image)
    (let* ((image (make-array (list (+ h 2) (+ w 2)) :element-type 'bit :initial-element 0))
	   (strings nil) )
      (my-bitblt h w edge-image 0 0 image 1 1)
      (loop for i from 1 to h
            doing
	(loop for j from 1 to w
            doing
	  (when (= 1 (aref image i j))
	    (push (grow-string image j i) strings) )))
      strings )))

(defun MY-BITBLT (h w from-array from-start-row from-start-col 
                          to-array to-start-row to-start-col)
  (loop for fi from from-start-row to (+ from-start-row h -1)
        for ti from to-start-row 
        doing
     (loop for fj from from-start-col to (+ from-start-col w -1)
           for tj from to-start-col
           doing
           (setf (aref to-array ti tj) (aref from-array fi fj)))))



(defmacro SSIN (orient)
  `(let ((morient (mod ,orient 8)))
     (cond ((<  morient 2) (- 1 morient))
	   ((<= morient 4) -1)
	   ((<  morient 6) (- morient 5))
	   (T 1))))

(defmacro SCOS (orient)
  `(let ((morient (mod ,orient 8)))
     (cond ((<= morient 2) 1)
	   ((<  morient 4) (- 3 morient))
	   ((<= morient 6) -1)
	   (T (- morient 7)))))

(defun NEXT (edge-array cxy)
  (loop with (orient x y) = cxy
	and next
	for norient from (- orient 2) to (+ orient 2)
	for nx = (+ x (scos norient))
	and ny = (+ y (ssin norient)) do
   (when (= 1 (aref edge-array ny nx))
      (if next
	  (return nil)
	  (setq next (list norient nx ny)) ))
	finally (return next) ))

(defun PREVIOUS (edge-array cxy)
;  (format t "~&    Prev: ~a" cxy)
  (loop with (orient x y) = cxy
	and prev
	for norient from (+ orient 2) downto (- orient 2)
	for nx = (+ x (scos norient))
	and ny = (+ y (ssin norient))
	do
;    (format t " [~a ~a ~a ~a]" norient nx ny (aref edge-array ny nx))
    (when (= 1 (aref edge-array ny nx))
      (if prev
	  (return nil)
	  (setq prev (list norient nx ny)) ))
	finally (return prev) ))

(defun TRACE-TO-END (edge-array x y)
  "Given an edge array and a point, finds the beginning of the string that contains
   this point.  If the string is circular, the initial point is returned.  A second
   value of t indicates a circular string"
;  (format t "~&  Trace-to-end: ~a ~a" x y)
  (loop for first? in *FIRST-T-THEN-NIL*
        for pcxy = (if first? (previous edge-array (list 1 x y)) (previous edge-array pcxy))
	and cxy = (if first? (list 1 x y) pcxy)
	until (null pcxy)
	if (and (= (second pcxy) x)
		(= (third pcxy) y) )
	  do (return (values cxy T))
	finally (return (values cxy nil)) ))



(defun GROW-STRING (edge-array x y)
;  (format t "~&Grow-String: ~a ~a" x y)
  (let ((icxy (trace-to-end edge-array x y))
	(string) )
    (incf (car icxy) 4)
    (loop for first? in *FIRST-T-THEN-NIL*
          for cxy = (if first? icxy (next edge-array cxy))
	  for (nil x y) = cxy
	  until (null cxy)
	  do
      (setf (aref edge-array y x) 0)
      (push (make-point (1- x) (1- y)) string) )
;    (format t "~&~a" string)
    string ))

