; (c) 2008 Dmitri Hrapof <hrapof@common-lisp.ru>
; This file is distributed under the terms of the LLGPL.

(defpackage oci-rest
   (:use common-lisp oci cffi))
(in-package oci-rest)

(define-foreign-library kissfft
  (:unix "libkissfft.so")
  (t (:default "libkissfft")))

(use-foreign-library kissfft)

(defcfun "kiss_fft_alloc" :pointer (nfft :int) (inverse :int) (mem :pointer) (lenmem :pointer))
(defcfun "kiss_fft" :void (cfg :pointer) (fin :pointer) (fout :pointer))

(defcfun "kiss_fftr_alloc" :pointer (nfft :int) (inverse :int) (mem :pointer) (lenmem :pointer))
(defcfun "kiss_fftr" :void (cfg :pointer) (fin :pointer) (fout :pointer))

(defcfun "kiss_fftnd_alloc" :pointer (dims :pointer) (ndims :int) (inverse :int) (mem :pointer) (lenmem :pointer))
(defcfun "kiss_fftnd" :void (cfg :pointer) (fin :pointer) (fout :pointer))

(defcfun "kiss_fftndr_alloc" :pointer (dims :pointer) (ndims :int) (inverse :int) (mem :pointer) (lenmem :pointer))
(defcfun "kiss_fftndr" :void (cfg :pointer) (fin :pointer) (fout :pointer))

(defcfun "hr_mag_inv_phase" :void (height :int) (width :int) (ft1 :pointer) (ft2 :pointer) (mags :pointer))
(defcfun "hr_mag_fft" :void (height :int) (width :int) (inverse :int) (ft1 :pointer) (ft2 :pointer) (mags :pointer))
(defcfun "hr_rotate" :void (height :int) (width :int) (angle :float) (in :pointer) (out :pointer))


(defcstruct kiss-fft-cpx
  (r :float)
  (i :float))

(defmacro with-kiss ((cfg-var init-form) &body body)
  `(let ((,cfg-var ,init-form))
     (unwind-protect
	  (progn ,@body)
       (foreign-free ,cfg-var))))

(defun c-fft! (complex-vector)
  (declare (optimize (speed 3) (safety 0)))
  (let ((n (length complex-vector)))
    (with-kiss (kfg (kiss-fft-alloc n 0 (null-pointer) (null-pointer)))
      (with-foreign-object (fin 'kiss-fft-cpx n)
	(dotimes (k n)
	  (with-foreign-slots 
	      ((r i) (mem-aref fin 'kiss-fft-cpx k) kiss-fft-cpx)
	    (setf r (coerce (realpart (aref complex-vector k)) 'single-float)
		  i (coerce (imagpart (aref complex-vector k)) 'single-float))))
	(with-foreign-object (fout 'kiss-fft-cpx n)
	  (kiss-fft kfg fin fout)
	  (dotimes (k n complex-vector)
	    (with-foreign-slots 
		((r i) (mem-aref fout 'kiss-fft-cpx k) kiss-fft-cpx)
	      (setf (aref complex-vector k) (complex r i)))))))))

(defun c-fft-2d! (image &optional inverse)
  (declare (optimize (speed 3) (safety 0)))
  (let ((h (array-dimension image 0))
	(w (array-dimension image 1))
	(s (array-total-size image)))
    (with-foreign-object (dims :int 2)
      (setf (mem-aref dims :int 0) h (mem-aref dims :int 1) w)
      (with-kiss (kfg (kiss-fftnd-alloc 
		       dims 2 (if inverse 1 0) (null-pointer) (null-pointer)))
	(with-foreign-object (fin 'kiss-fft-cpx s)
	  (dotimes (k h)
	    (dotimes (j w)
	      (with-foreign-slots 
		  ((r i) (mem-aref fin 'kiss-fft-cpx (+ (* k w) j)) 
		   kiss-fft-cpx)
		(setf r (coerce (realpart (aref image k j)) 'single-float)
		      i (coerce (imagpart (aref image k j)) 'single-float)))))
	  (with-foreign-object (fout 'kiss-fft-cpx s)
	    (kiss-fftnd kfg fin fout)
	    (dotimes (k h image)
	      (dotimes (j w)
		(with-foreign-slots 
		    ((r i) (mem-aref fout 'kiss-fft-cpx (+ (* k w) j))
		     kiss-fft-cpx)
		  (setf (aref image k j) (complex r i)))))))))))

(defun c-inverse-fft-2d! (image) (c-fft-2d! image t))

(defun c-fft-2d&mags! (image)
  (declare (optimize (speed 3) (safety 0)))
  (let ((h (array-dimension image 0))
	(w (array-dimension image 1))
	(s (array-total-size image))
	(lmage (make-array (array-dimensions image))))
    (with-foreign-object (fin 'kiss-fft-cpx s)
      (dotimes (k h)
	(dotimes (j w)
	  (with-foreign-slots 
	      ((r i) (mem-aref fin 'kiss-fft-cpx (+ (* k w) j)) 
	       kiss-fft-cpx)
	    (setf r (coerce (realpart (aref image k j)) 'single-float)
		  i (coerce (imagpart (aref image k j)) 'single-float)))))
      (with-foreign-object (fout 'kiss-fft-cpx s)
	(with-foreign-object (mag :float s)
	  (hr-mag-fft h w 0 fin fout mag)
	  (dotimes (k h (values lmage image))
	    (dotimes (j w)
	      (let ((l (+ (* k w) j)))
		(with-foreign-slots 
		    ((r i) (mem-aref fout 'kiss-fft-cpx l)
		     kiss-fft-cpx)
		  (setf (aref image k j) (complex r i)))
		(setf (aref lmage k j) (mem-aref mag :float l))))))))))
	    

(defun c-real-fft-2d! (image)
  (declare (optimize (speed 3) (safety 0)))
  (let ((h (array-dimension image 0))
	(w (array-dimension image 1))
	(s (array-total-size image)))
    (with-foreign-object (dims :int 2)
      (setf (mem-aref dims :int 0) h (mem-aref dims :int 1) w)
      (with-kiss (kfg (kiss-fftndr-alloc 
		       dims 2 0 (null-pointer) (null-pointer)))
	(with-foreign-object (fin :float s)
	  (dotimes (k h)
	    (dotimes (j w)
	      (setf (mem-aref fin :float (+ (* k w) j)) 
		    (coerce (aref image k j) 'single-float))))
	  (with-foreign-object (fout 'kiss-fft-cpx s)
	    (kiss-fftndr kfg fin fout)
	    (let ((h/2 (/ h 2)) (w/2 (/ w 2)))
	      (dotimes (k h)
		(dotimes (j (1+ w/2))
		  (with-foreign-slots 
		      ((r i) (mem-aref fout 'kiss-fft-cpx 
				       (+ (* k (1+ w/2)) j))
		       kiss-fft-cpx)
		    (setf (aref image k j) (complex r i)))))

	      (loop for j from 1 below w/2 do
		   (loop for k from 0 below h by h/2 do
			(setf (aref image k (+ j w/2))
			      (conjugate (aref image k (- w/2 j))))))

	      (loop for k from 1 below h/2 do
		   (loop for j from 1 below w/2 do
			(setf (aref image (- h/2 k) (+ j w/2))
			      (conjugate (aref image (+ k h/2) (- w/2 j))))))

	      (loop for k from 1 below h/2 do
		   (loop for j from 1 below w/2 do
			(setf (aref image (+ k h/2) (+ j w/2))
			      (conjugate (aref image (- h/2 k) (- w/2 j))))))
	      ))))))
  image)

(defun c-fourier-correlation! (f1 f2)
  (declare (optimize (speed 3) (safety 0)))
  (let ((h (array-dimension f1 0))
	(w (array-dimension f2 1))
	(s (array-total-size f1)))
    (with-foreign-object (ft1 'kiss-fft-cpx s)
      (dotimes (k h)
	(dotimes (j w)
	  (with-foreign-slots 
	      ((r i) (mem-aref ft1 'kiss-fft-cpx (+ (* k w) j)) 
	       kiss-fft-cpx)
	    (setf r (coerce (realpart (aref f2 k j)) 'single-float)
		  i (coerce (imagpart (aref f2 k j)) 'single-float)))))
      (with-foreign-object (ft2 'kiss-fft-cpx s)
	(dotimes (k h)
	  (dotimes (j w)
	    (with-foreign-slots 
		((r i) (mem-aref ft2 'kiss-fft-cpx (+ (* k w) j)) 
		 kiss-fft-cpx)
	      (setf r (coerce (realpart (aref f1 k j)) 'single-float)
		    i (coerce (imagpart (aref f1 k j)) 'single-float)))))
	(with-foreign-object (mag :float s)
	  (hr-mag-inv-phase h w ft1 ft2 mag)
	  (dotimes (k h f1)
	    (dotimes (j w)
	      (setf (aref f1 k j) (mem-aref mag :float (+ (* k w) j))))))))))

(defun c-rotate (image a)
  (declare (optimize (speed 3) (safety 0)))
  (let ((h (array-dimension image 0))
	(w (array-dimension image 1))
	(s (array-total-size image))
	(lmage (make-array (array-dimensions image))))
    (with-foreign-object (in :unsigned-char s)
      (dotimes (k h)
	(dotimes (j w)
	  (setf (mem-aref in :unsigned-char (+ (* k w) j)) (aref image k j))))
      (with-foreign-object (out :unsigned-char s)
	(hr-rotate h w (coerce a 'single-float) in out)
	(dotimes (k h lmage)
	  (dotimes (j w)
	    (setf (aref lmage k j) (mem-aref out :unsigned-char (+ (* k w) j)))))))))

(defun commit-adultery ()
  (setf 
   (fdefinition 'oci::fft-2d!) (function oci-rest::c-fft-2d!)
   (fdefinition 'oci::real-fft-2d!) (function oci-rest::c-real-fft-2d!)
   (fdefinition 'oci::inverse-fft-2d!) (function oci-rest::c-inverse-fft-2d!)
   (fdefinition 'oci::fourier-correlation!) (function oci-rest::c-fourier-correlation!)
   (fdefinition 'oci::fft-n-mags!) (function oci-rest::c-fft-2d&mags!)
   (fdefinition 'oci::rotate-image) (function oci-rest::c-rotate)))
   
(defun jpeg->gray (filename &optional (channel 1))
  (multiple-value-bind (a h w) (jpeg:decode-image filename)
    (let ((image (make-array (list h w) :element-type '(unsigned-byte 8)))
	  (stride (/ (array-total-size a) h w)))
      (dotimes (i h image)
	(dotimes (j w) 
	  (setf (aref image i j) 
		(aref a (+ (* i w stride) (* j stride) channel))))))))

(defparameter *figures1* nil)
(defparameter *figures2* nil)
(defparameter *figures* nil)
(defparameter *hvigures* nil)
(defparameter *n0* 0)
(defparameter *n1* 0)
(defparameter *mnogo1* nil)
(defparameter *mnogo2* nil)
(defparameter *mnogo* nil)
(defparameter *muogo* nil)
    
(defun slurp-numbers! ()
;  (setf *mnogo1* (read-netpbm (format nil "~~/Desktop/mnogo.pnm")))
  (let ((f (make-array 2 :initial-element nil)))
    (dotimes (k 2)
      (dotimes (i 10)
	(let ((mask (read-netpbm (format nil "~~/im/all/~ax~a.pnm" k i))))
	  (push (list i mask) (svref f k)))))
    (setf *figures1* f))
  t)

(defun find-8s (image)
  (let ((ht (grayscale-image (hough+sobel-circle-transform (/ 6 *res*) image)))
	circles)
    (dotimes (i (array-dimension image 0))
      (dotimes (j (array-dimension image 1))
	(when (< 150 (aref ht i j)) (push (cons i j) circles))))
;    (format t "~a~%" circles)
    (remove-if 
     #'null
     (mapcar
      #'(lambda (g)
	  (if (> (length g) 1)
	      (cons
	       (round (apply #'average (mapcar #'car g)))
	       (round (apply #'average (mapcar #'cdr g))))))
      (group #'(lambda (a b) (and (> (/ 15 *res*) (abs (- (car a) (car b))))
				  (> (/ 6 *res*) (abs (- (cdr a) (cdr b))))))
	     circles :every t)))))

(defun unite-centres (image lst)
  (let (eights eights-p)
    (mapcar
     #'(lambda (g)
;       (format t "GG ~a~%" g)
	 (let ((w (car (sort (copy-list g) #'> 
			     :key #'(lambda (e) (third (second e)))))))
	   (when (and (member (car w) '(3 5)) (member 8 g :key #'car))
	     (if (null eights-p) 
		 (setf eights-p t eights (find-8s image))) ;not very functional 
;	     (format t " ~a ~a ~a ~a~%" (car w) (mapcar #'car g) (cons (car (second w)) (cadr (second w))) eights)
	     (if (member 
		  (cons (car (second w)) (cadr (second w))) eights
		  :test #'(lambda (a b) 
			    (> *rec-num-hor* (euclidean-distance a b))))
		 (setf (car w) 8)))
	   (list (car w) (cons (car (second w)) (cadr (second w)))
		 (third (second w)))))
	 (group 
	  #'(lambda (a b)
	      (and (> (* 2 *rec-num-hor*) (abs (- (first a) (first b))))
		   (> (* 1.5 *rec-num-hor*) (abs (- (second a) (second b))))))
	  lst :every t :key #'second))))

(defparameter *rec-num-hor1* 10)

(defun unite-middles (lst)
  (sort
   (mapcar
    #'(lambda (g) (car (sort g #'< :key #'second)))
    (group 
     #'(lambda (a b)
	 (and (> (* 2 *rec-num-hor1*) (abs (- (point-i a) (point-i b))))
	      (> (* 1.5 *rec-num-hor1*) (abs (- (point-j a) (point-j b))))))
     lst :every t :key #'third))
   #'oci::hor-point< :key #'third))

(defun recognize-number (image)
  (apply
   #'values
   (sort
    (mapcar
     #'(lambda (n)
	 (let ((s 
		(format nil "~{~a~}" 
			(mapcar #'car (sort n #'oci::hor-point< :key #'cadr)))))
	   (list s (apply #'+ (mapcar #'third n)) (length s))))
     (group 
      #'(lambda (a b)
	  (and (< *rec-num-hor* (abs (- (cdr a) (cdr b))) *join-centres-pixels*)
	       (> *rec-num-ver* (abs (- (car a) (car b))))))
      (unite-centres 
       image
       (let (number)
	 (dolist (f *figures* number)
	   (let ((n (car f)) (m (cadr f)))
	     (dolist (p (fourier-search m image :t1 0.7 :mask-cooked-p t))
	       (if (> (third p) 400) (push (list n p) number)))))))
      :key #'second))
    #'> :key #'third)))

(defun recognize-011 (image)
  (apply
   #'values
   (sort
    (mapcar
     #'(lambda (n)
	 (let ((s 
		(format nil "~{~a~}" 
			(mapcar #'car (sort n #'oci::hor-point< :key #'cadr)))))
	   (list s (apply #'+ (mapcar #'third n)) (length s))))
     (group 
      #'(lambda (a b)
	  (and (< *rec-num-hor* (abs (- (cdr a) (cdr b))) *join-centres-pixels*)
	       (> *rec-num-ver* (abs (- (car a) (car b))))))
      (unite-centres 
       image
       (let* ((number)
	      (n0 (power-of-2-ceiling (array-dimension image 0)))
	      (n1 (power-of-2-ceiling (array-dimension image 1)))
	      (ifage (oci::real-fft-2d! (pad-image n0 image n1)))
	      (ijage (oci::real-fft-2d! 
		      (oci::rotate-image (pad-image n0 image n1) pi))))
	 (if (or (/= n0 *n0*) (/= n1 *n1*))
	     (stew-numbers (setf *n0* n0) (setf *n1* n1)))
	 (let ((d0 (apply
		    #'max
		    (mapcar 
		     #'third
		     (fourier-search 
		      *mnogo* image :mask-cooked-p t :image-cooked-p ifage))))
	       (d1 (apply
		    #'max
		    (mapcar 
		     #'third
		     (fourier-search 
		      *muogo* image :mask-cooked-p t :image-cooked-p ifage)))))
;	   (format t "~a ~a~%" d0 d1)
	   (if (or (> d0 50) (> d1 50))
	       (dolist (f *figures* number)
		 (let ((n (car f)) (m (cadr f)))
		   (dolist (p (fourier-search 
			       m image :t1 0.7 
			       :image-cooked-p (if (> d0 d1) ifage ijage)
			       :mask-cooked-p t))
		     (push (list n p) number))))
	       '((0 (0 0 0)))))))
      :key #'second))
    #'> :key #'third)))

(defparameter *res* 1)
(defparameter *rec-num-hor* 10)
(defparameter *rec-num-ver* 7)
(defparameter *join-centres-angles* 5)
(defparameter *join-centres-pixels* 25)
(defparameter *number-rects* '((90 -120 210 120)))

(defun switch-resolution (r)
  (setf *res* r
	*join-centres-pixels* (/ 25 r)
	*rec-num-hor* (/ 10 r)
	*rec-num-ver* (/ 7 r)
	*number-rects* 
	(mapcar
	 #'(lambda (b) (mapcar #'(lambda (c) (floor c r)) b))
	 '((90 -120 210 120)))))

(defun cook-numbers (r)
  (let ((h (power-of-2-ceiling (/ 120 r)))
	(w (power-of-2-ceiling (/ 240 r))))
    (setf
     *mnogo* (treshold-fourier! 0.1 (pad-image h (shrink-image r *mnogo1*) w))
     *figures*
     (mapcar
      #'(lambda (p)
	  (list 
	   (car p)
	   (treshold-fourier! 0.1 (pad-image h (shrink-image r (cadr p)) w))))
      *figures1*))))

(defun hook-numbers (k r)
  (setf
    *hvigures*
   (mapcar 
    #'(lambda (p)
	(let ((i (grayscale->graymap! (shrink-image r (cadr p))))) ; g->g?
	  (list (car p) i (chamfer-transform! (image-not i))))) 
    (svref *figures1* k)))
  t)

(defun roast-numbers (r)
  (setf
   *mnogo2* (shrink-image r *mnogo1*)
   *figures2*
   (mapcar #'(lambda (p) (list (car p) (shrink-image r (cadr p)))) *figures1*))
  t)

(defun stew-numbers (n0 n1)
  (setf
   *mnogo* (treshold-fourier! 0.1 (pad-image n0 *mnogo2* n1))
   *muogo* 
   (treshold-fourier! 0.1 (oci::rotate-image (pad-image n0 *mnogo2* n1) pi))
   *figures*
   (mapcar 
    #'(lambda (p) 
	(list (car p) (treshold-fourier! 0.1 (pad-image n0 (cadr p) n1)))) 
    *figures2*))
  t)

(defun get-centres (sc blackmaskname jpegname &key debug-p w)
  (apply
   #'append
   (let* ((msk (logarithm-filter (read-netpbm blackmaskname)))
	  (jpeg (negate-grayscale-image (jpeg->gray jpegname)))
	  (jh (array-dimension jpeg 0)) (jw (array-dimension jpeg 1))
	  (sm (> (* 0.9 666 486) (array-total-size jpeg)))
	  (blacksmalljpeg1
	   (if (null w)
	       (logarithm-filter 
		(shrink-image 
		 sc 
		 (if (or (> 666 jw) (> 486 jh)) jpeg
		     (copy-rect 
		      (list (- (floor jh 2) 243) 0 ;(- (floor jw 2) 333)
			    (+ (floor jh 2) 243) 666) ;(+ (floor jw 2) 333))
		      jpeg))))))
	  (blacksmalljpeg (logarithm-filter (shrink-image sc jpeg)))
	  (mask 
	   (progn
	     (if (null w)
		 (setf w (* 0.1 (round (fourier-mellin-search msk blacksmalljpeg1 :debug-p debug-p :t2 (if sm 0.15 0.2) :t3 (if sm 0.1 0.2) :t4 2.5 :dry t) 0.1))))
	     (shrink-image w msk)))
	  (ccss (fourier-mellin-search mask blacksmalljpeg :debug-p debug-p :t0 (* w 0.3) :t1 (if sm 0.3 0.5) :t2 (if sm 0.05 0.5) :t3 (if sm 0.05 0.2))) 
	  (cs 
	   (progn
	     (switch-resolution w)
	     (join-centres
	      *join-centres-angles* *join-centres-pixels*
	      (filter-centres 60 95 blacksmalljpeg ccss)))))
     (when debug-p
       (format t "# ~a~%" (length cs))
       (write-netpbm "~/im/0-0-0-0.pnm" (mark-image blacksmalljpeg cs)))
     (cook-numbers w)
     (mapcar
      #'(lambda (c)
	  (interleave
	   #'(lambda (r a o)
	       (let ((k (restore-rect r a o jpeg)))
		 (list c k (if k (round (image-mean k))) a
		       (eq r (car *number-rects*)))))
	   nil
	   *number-rects*
	   (list (fourth c))
	   (list (cons (* sc (first c)) (* sc (second c))))))
      cs))))

(defun ignore-nulls (centres &optional debug-p)
  (remove-if 
   #'(lambda (e)
       (when (and debug-p (second e))
	 (let ((c (first e)))
	   (write-netpbm
	    (format 
	     nil "~~/im/all/~a-~a-~a-~a-~a-~a.pnm" 'x
	     (first c) (second c) (round (fourth e)) (third e) (fifth e))
	    (second e))))
       (or
	(null (second e))
	(not (< 10 (third e) 35))
	(> 150
	   (apply
	    #'max
	    (mapcar 
	     #'third
	     (fourier-search *mnogo* (second e) :mask-cooked-p t)))))) 
   centres))

(defun find-numbers (lst &optional debug-p)
  (if debug-p (format t "№ ~a~%" (length lst)))
  (mapcar
   #'(lambda (i)
       (let ((c (first i)) (n (recognize-number (second i))))
	 (if debug-p
	     (if (> (length (car n)) 6)
		 (write-netpbm
		  (format 
		   nil "~~/im/~a-~a-~a-~a-~a-~a.pnm" (car n)
		   (first c) (second c) (round (fourth i)) (third i) (fifth i))
		  (second i))
		 (write-netpbm
		  (format 
		   nil "~~/im/bad/~a-~a-~a-~a-~a-~a.pnm" (car n)
		   (first c) (second c) (round (fourth i)) (third i) (fifth i))
		  (second i))))
	 (append n (list (first c) (second c) (round (fourth i))))))
   lst))

(defun unite-numbers (n)
  (sort
;   (remove-duplicates
    (mapcar
     #'(lambda (g) 
	 (car 
	  (sort 
	   g 
	   #'(lambda (a b) 
	       (if (= (third a) (third b)) 
		   (> (cadr a) (cadr b))
		   (> (third a) (third b)))))))
     (oci:group 
      #'(lambda (a b) 
	  (and (> *join-centres-pixels* (abs (- (fifth a) (fifth b))))
	       (> *join-centres-pixels* (abs (- (fourth a) (fourth b))))))
;	       (> 0.35 (abs (- (sin (* pi (/ (sixth a) 180))) 
;			       (sin (* pi (/ (sixth b) 180))))))))
      n :every t))
 ;   :test #'string= :key #'car)
   #'string< :key #'car))

(defun fm-jpeg-search (sc blackmaskname jpegname &key debug-p w)
  (remove-if
    #'(lambda (x) (or (not (stringp x)) (not (< 6 (length x) 10))))
    (find-numbers 
     (ignore-nulls 
      (get-centres sc blackmaskname jpegname :debug-p debug-p :w w) debug-p)
     debug-p)
    :key #'car))

(defun n-average (c s g a n)
  (if (null n) (nreverse (cons (/ g c) a))
      (if (= c s) (n-average 1 s (car n) (cons (/ g c) a) (cdr n))
	  (n-average (1+ c) s (+ g (car n)) a (cdr n)))))	  

(defun rect-extents (points)
  (loop for p in points
     maximize (point-i p) into imax
     minimize (point-i p) into imin
     maximize (point-j p) into jmax
     minimize (point-j p) into jmin
     count p into len
     finally (return (values imin jmin imax jmax len))))

(defun separate (a)
  (multiple-value-bind (imin jmin imax jmax)
      (rect-extents a)
    (declare (ignore imax imin))
    (let ((delta (round (- jmax jmin) 8)))
      (loop for i below 8 
	 for j0 from jmin by delta 
	 for j1 from (+ jmin delta) by delta
	 collect (remove-if-not #'(lambda (p) (<= j0 (cdr p) j1)) a)))))

(defun locate-angle (a)
  (multiple-value-bind (imin jmin imax jmax len)
      (rect-extents a)
    (let ((b (sort 
	      (copy-list a) #'< 
	      :key (if (> (- imax imin) (- jmax jmin)) #'point-i #'point-j)))
	  (p (floor len 8)))
      (let ((1st (subseq b 0 p)) (2nd (subseq b (- len p))))
	(let ((i0 (apply #'average (mapcar #'point-i 1st)))
	      (i1 (apply #'average (mapcar #'point-i 2nd)))
	      (j0 (apply #'average (mapcar #'point-j 1st)))
	      (j1 (apply #'average (mapcar #'point-j 2nd))))
	  (atan (- i1 i0) (- j1 j0 1)))))))

(defun @-point (c s p)
  (let ((i (+ (* (point-i p) c) (* (point-j p) s)))  
	(j (- (* (point-j p) c) (* (point-i p) s))))
    (let ((i0 (floor i)) (i1 (ceiling i))
	  (j0 (floor j)) (j1 (ceiling j))
	  (b (new-point i j)))
     (mapcar
      #'car
      (remove-if 
       #'(lambda (p) (> 0.175 (abs (cadr p))))
       (mapcar
	#'(lambda (p) (list p (- 1 (euclidean-distance p b))))
	(interleave #'new-point nil (list i0 i1) (list j0 j1))))))))

(defun rotate-points (a pts)
  (let ((c (cos a)) (s (sin a)))
    (remove-duplicates 
     (apply #'append (mapcar #'(lambda (p) (@-point c s p)) pts))
     :test #'equal)))

(defun restore-number (g) (let ((u (locate-angle g))) (values (rotate-points (- u) g) u)))

(defun restore-numbers (lst) (mapcar #'restore-number lst))

(defun sort-line (points)
  (oci::sort-rect 
   (multiple-value-bind (imin jmin imax jmax) 
       (rect-extents points)
     (if (or (zerop (- imax imin))
	     (> (/ (- jmax jmin) (- imax imin)) 2)) :hor t))
   (copy-list points)))

(defun %point-line-distance (p q1 q2 q3 q4)
  "Corman Lisp is defective"
  (abs (/ (+ q3 (* q1 (point-i p)) (* q2 (point-j p))) q4)))

(defun point-line-distance (s p e)
  (%point-line-distance
   p
   (- (point-j s) (point-j e))
   (- (point-i e) (point-i s))
   (- (* (point-i s) (point-j e)) (* (point-i e) (point-j s)))
   (euclidean-distance s e)))

(defun some-line-p (r points &optional debug)
  "объединить с same-line-p"
  (let ((pts (sort-line points)))
    (let ((s (car pts))
	  (e (car (last pts))))
      (when debug (format t "slp ~a ~a ~%~a~%" s e points))
      (let ((q1 (- (point-j s) (point-j e))) 
	    (q2 (- (point-i e) (point-i s)))
	    (q3 (- (* (point-i s) (point-j e)) (* (point-i e) (point-j s))))
	    (q4 (euclidean-distance s e)))
	(let ((vals 
	       (mapcar 
		#'(lambda (p) (%point-line-distance p q1 q2 q3 q4)) 
		points)))
	  (when debug (format t "slp ~a~%" vals))
	  (let ((rat (/ (count-if #'(lambda (v) (>= r v)) vals) 
			(length points))))
	    (> rat 0.9)))))))

(defun typ-o-distance (d a b)
  (and (> d (abs (- (point-i a) (point-i b))))
       (> d (abs (- (point-j a) (point-j b))))))

(defun locate-lines (lst &key (t0 2) (t1 2))
  (group 
   #'(lambda (a b) ;(> t0 (euclidean-distance a b)))
       (typ-o-distance t0 a b))
   lst
   :rem #'(lambda (a aa) 
	    (remove-if #'(lambda (p) (not (typ-o-distance 150 a p))) aa))
   :not-every t
   :every 
   #'(lambda (g p) (some-line-p t1 (cons p g)))))

(defun avinist (dots)
  (apply
   #'average
   (loop for d in dots collect 
	(loop for p in (remove d dots) minimize (euclidean-distance p d)))))

(defun number-centres (dots)
  (mapcar 
   #'(lambda (g) 
       (new-point 
	(round (apply #'average (mapcar #'point-i g))) 
	(round (apply #'average (mapcar #'point-j g)))))
   (group #'(lambda (a b) (typ-o-distance 10 a b)) dots :every t)))

(defun number-lines (dots &optional debug)
  (let* ((centres (number-centres dots)) (ad (1+ (* 2 (avinist centres)))))
    (when debug (format t "]-[ ~a~%" ad))
    (locate-lines centres :t0 ad :t1 ad)))

(defun vote-for-lines (dots)
  (let ((len (length dots)) (m 0) (x 0) (y 0))
    (let ((g (make-array (list len len))))
      (dotimes (i len)
	(dotimes (j len)
	  (if (= i j) (setf (aref g i j) nil))
	  (when (not (null (aref g i j)))
	    (setf (aref g j i) nil)
	    (dotimes (k len)
	      (when (and (/= k i) (/= k j)
			 (> 5 (point-line-distance 
			       (nth i dots) (nth k dots) (nth j dots))))
		(incf (aref g i j)))))))
       (dotimes (i len)
	 (dotimes (j len)
	   (if (and (aref g i j) (> (aref g i j) m))
	       (setf m (aref g i j) y i x j))))
       (list (nth y dots) (nth x dots)))))
	       

(defun situate-number (dots &optional debug)
  (let ((c (number-centres dots)))
    (when debug
      (write-netpbm 
       "~/Desktop/r.pnm" (bitmap->grayscale! (instantiate-rectangle c))))
    (let ((l (vote-for-lines c)))
      (when debug (format t "~a~%" l))
      (remove-if 
       #'(lambda (p) (< 18 (point-line-distance (car l) p (cadr l)))) 
       dots))))

(defun locate-numbers (t0 t1 t2 lst &optional debug) ; перенести let вниз
  (let* ((gg (group 
	      #'(lambda (a b) (typ-o-distance t0 a b))
	      lst
	      :rem #'(lambda (a aa) 
		       (remove-if #'(lambda (p) (not (typ-o-distance 150 a p)))
				  aa))
	      ))
	 (ggg (group
	       #'(lambda (a b)
		   (some #'(lambda (a1)
			     (some
			      #'(lambda (b1)
				  (typ-o-distance (* t1 1.5) a1 b1))
			      b))
			 a))
	       gg
	       :not-every t
	       :every 
	       #'(lambda (g p)
		   (let ((pp (apply #'append (cons p g))))
		     (and 
		      (some-line-p (* t2 1.5) pp)
		      (> (* 20 t0) (oci::sb-length (sort-line pp))))))))
	(groups 
	 (mapcar
	  #'(lambda (g) (let ((h (apply #'append g))) (list (length h) h)))
	    ggg)))
    (mapcar 
     #'(lambda (g) (situate-number (second g)))
     (remove-if 
      #'(lambda (a)
	  (when debug
	    (write-netpbm 
	     (format nil "~~/im/all/~a-~a-~a.pnm" 
		     (caar (second a)) (cdar (second a)) (car a))
	     (bitmap->grayscale! (instantiate-rectangle (second a))))
	    (if (<= 150 (car a))
		(write-netpbm 
		 (format nil "~~/im/all/X-~a-~a-~a.pnm" 
			 (caar (second a)) (cdar (second a)) (car a))
		 (bitmap->grayscale! 
		  (instantiate-rectangle (situate-number (second a)))))))
	  (> 150 (car a))) groups))))

(defun color->gray (a h w c)
  (let ((image (make-array (list h w))))
    (dotimes (i h image)
      (dotimes (j w)
	(let ((u (+ (* i w c) (* j c))))
	  (setf (aref image i j)
		(round
		 (average 
		  (aref a (+ u 0)) 
		  (aref a (+ u 1)) 
		  (aref a (+ u 2))))))))))

(defun get-lines (h w image)
;  (let ((r0 (/ (ceiling (sqrt (+ (expt h 2) (expt w 2)))) 2.0))
;	lines)
;    (dotimes (i (array-dimension image 0))
;      (dotimes (j (array-dimension image 1))
;	(push (list (aref image i j) (cons (- i r0) (* pi (/ j 180)))) lines)))
;    (mapcar #'cadr (subseq (sort lines #'> :key #'car) 0 10))))
    
  (format t "~a ~a ~a~%" (* 0.15 (nth-value 2 (oci::image-max image)) )
	  (float (image-mean image)) (* 255 50))
  (let ((m (max (* 255 50) (* 0.15 (nth-value 2 (oci::image-max image)))))
	(r0 (/ (ceiling (sqrt (+ (expt h 2) (expt w 2)))) 2.0))
;	(m1 0) (c 0)
	lines)
;    (dotimes (i (array-dimension image 0))
;      (dotimes (j (array-dimension image 1))
;	(if (> (aref image i j) m)
;	    (progn
;	      (incf m1 (aref image i j))
;	      (incf c)))))
;    (setf m (/ m1 c))
;    (format t "~a ~a~%" m c)
    (dotimes (i (array-dimension image 0) lines)
      (dotimes (j (array-dimension image 1))
	(if (> (aref image i j) m)
	    (push (cons (- i r0) (* pi (/ j 180))) lines))))))

(defun mark-lines (h w lines)
  (let ((image (make-array (list h w)))
	(h2 (/ h 2)) (w2  (/ w 2)))
    (dotimes (i h image)
      (dotimes (j w)
	(if (point-in-lines (- i h2) (- j w2) lines)
	    (setf (aref image i j) 1))))))

; xcosθ + ysinθ = r

(defun point-in-line-p (i j line)
  (let ((r (car line)) (a (cdr line)))
    (> 5 (abs (- r (+ (* i (sin a)) (* j (cos a))))))))

(defun point-in-lines (i j lines)
  (some #'(lambda (l) (point-in-line-p i j l)) lines))

(defun bitmap->grayscale! (image)
  (dotimes (i (array-dimension image 0) image)
    (dotimes (j (array-dimension image 1))
      (setf (aref image i j) (* (aref image i j) 255)))))

(defparameter *black* 150)
(defparameter *white* 150)
(defparameter *nblack* 180)

(defun test-white (a h w c)
  (let ((dots))
    (dotimes (i h dots)
      (dotimes (j w)
	(let ((u (+ (* i w c) (* j c))))
	  (format t "~a ~a ~a ~a ~a~%" i j 
		  (aref a (+ u 2)) (aref a (+ u 1)) (aref a (+ u 0)))
	  (if (and (< 180 (aref a (+ u 2)) 256)  
		   (< 170 (aref a (+ u 1)) 256) 
		   (< 150 (aref a (+ u 0)) 256))
	      (push (new-point i j) dots)))))))

(defun test-black (a h w c)
  (let ((dots))
    (dotimes (i h dots)
      (dotimes (j w)
	(let ((u (+ (* i w c) (* j c))))
	  (if (not (and (< 0 (aref a (+ u 2)) *black*)  
			(< 0 (aref a (+ u 1)) *black*) 
			(< 0 (aref a (+ u 0)) *black*)))
	      (push (new-point i j) dots)))))))


(defun find-black-text (a h w c &key div)
  (let ((dots (if div (make-list (+ div (1- div))))))
    (flet ((white-p (u)
	     (and (< *white* (aref a (+ u 2)) 256)   ;r
		  (< *white* (aref a (+ u 1)) 256)   ;g
		  (< *white* (aref a (+ u 0)) 256))) ;b
	   (black-p (u)
	     (and (< 0 (aref a (+ u 2)) *black*)
		  (< 0 (aref a (+ u 1)) *black*)
		  (< 0 (aref a (+ u 0)) *black*))))
      (dotimes (i h dots)
	(dotimes (j w)
	  (let ((u (+ (* i w c) (* j c))))
	    (if (and 
		 (black-p u)
		 (let ((white 0) (black 0))
		   (loop for k from (- i 10) below (+ i 10) do
			(loop for l from (- j 10) below (+ j 10) do
			     (if (and (< -1 k h) (< -1 l w))
				 (let ((y (+ (* k w c) (* l c))))
				   (when (black-p y) (incf black))
				   (when (white-p y) (incf white))))))
		   (and (> (+ white black) 200)
			(< 10 black *nblack*))))
		(let ((np (new-point i j)))
		  (if div
		      (progn
			(push np (nth (floor (* div (/ i h))) dots))
			(let ((d (1- (floor (* div (/ (+ i (/ h div 2)) h))))))
			  (if (< -1 d (1- div))
			      (push np (nth (+ div d) dots)))))
		      (push np dots))))))))))

(defun av-space (image &optional (r (list 0 0 (array-dimension image 0) (array-dimension image 1))) (c 0) s ss)
  (if (= c (array-dimension image 1)) (apply #'average ss)
      (if (oci::blank-column-p image r c 1)
	  (if s (av-space image r (1+ c) s ss)
	      (av-space image r (1+ c) c ss))
	  (if s (av-space image r (1+ c) nil (cons (- c s) ss))
	      (av-space image r (1+ c) nil ss)))))
  

(defun observe-number (tree image)
  (let ((w (array-dimension image 1))
	(h (array-dimension image 0))
	(s (av-space image)))
    (let ((x (/ (+ w s) 8)))
      (coerce
       (remove-if
	#'null
	(loop for j from (/ s -2) below (+ w (/ s 2)) by x
	      collect
	     (let ((d  (copy-rect
		    (list 0 (round (max 0 j)) 
			  h (round (min w (+ j x))))
		    image)))
	       (if (< 0.09 (float (image-mean d)) 0.6)
		   (car
		    (gather-fruit 
		     tree 
		     (graphicalize 
		      ;(prune
		       ;(reap-meat 
		      d);))
		     :char t))))))
	'string))))

(defun approve-digit (no)
  (multiple-value-bind (k b c)
      (oci::test-img 
       4
       (let ((w (array-dimension *omg* 1))
	     (h (array-dimension *omg* 0)))
	 (let ((x (/ w (+ (* 7 2) (* 8 3)))))
;	   (prune
;	    (reap-meat
	     (copy-rect
	      (list 0 (round (max 0 (+ (- x) (* x 5 no))))
		    h (round (min w (+ (- x) (* x 5 (1+ no))))))
	      *omg*))));))	     
    (format t "~%~a~%~a~%~a~%" k b c)
    (when (or (null c) (not (zerop (caar c)))) (oci::remember-blocks 4 b))))

(defun turn-over (number)
  "lzEhs9L860"
  (let ((a '((#\1 . #\1) (#\2 . #\2) (#\4 . #\4) (#\5 . #\5) (#\7 . #\7)
	     (#\l . #\1) (#\z . #\2) (#\3 . #\3) (#\E . #\3) 
	     (#\h . #\4) (#\s . #\5) 
	     (#\6 . #\9) (#\L . #\7) (#\8 . #\8) (#\9 . #\6) (#\0 . #\0))))
    (if (some #'(lambda (c) (member c '(#\l #\E #\z #\h #\s #\L))) number)
	(reverse (map 'string #'(lambda (c) (cdr (assoc c a))) number))
	number)))      
  
(defun redundant-number (image u a)
  (let ((r (/ (* 180 a) pi)))
    (multiple-value-bind (imin jmin imax jmax)
	(rect-extents u)
      (restore-rect 
       (list -1 -1 (- imax imin -1) (- jmax jmin -1)) r
       (oci::rotate-point r (new-point imin jmin)) image))))

(defun grayscale->graymap! (image)
  (dotimes (i (array-dimension image 0) image)
    (dotimes (j (array-dimension image 1))
      (setf (aref image i j) (if (> (aref image i j) 70) 1 0)))))

(defun mark-grayscale (h w dots &optional (b 255))
  (let ((image (make-array (list h w))))
    (dolist (p dots image) (setf (aref image (point-i p) (point-j p)) b))))
  
(defun remove-dots (dots)
  (apply
   #'append
   (remove-if 
    #'(lambda (g) (> 15 (length g)))
    (group #'(lambda (a b) (typ-o-distance 3 a b)) dots))))

(defun dot-neighbourhood (r dots)
  (let ((table (make-hash-table)))
    (dolist (d dots table)
      (dolist (p dots)
	(if (and (not (eq d p)) (typ-o-distance r d p))
	    (push p (gethash d table)))))))

(defun decipher-dots (h w tree dots &optional debug)
  (let* ((time0 (get-universal-time))
	 (lines 
	  (mapcar 
	   #'(lambda (l) 
	       (let ((s (sort-line l))) (list s (oci::sb-length s))))
	   (locate-lines dots)))
	 (lines1 
	  (remove-if 
	   #'(lambda (l) (or (> 3 (length (car l))) (> (second l) 30)))
	   lines))
;	     (all (apply #'average (mapcar #'cadr lines1)))
	 (oo.s
;	      (remove-dots
	  (apply #'append (mapcar #'car lines1))));)
    (when debug
      (format t "LOCATE LINES ~a s.~%" (- (get-universal-time) time0))
      (setf time0 (get-universal-time))
;      (write-netpbm
;       (format nil "~~/im/0-~a-0-1.pnm" debug)
;       (mark-grayscale 
;	h w
;	(apply 
;	 #'append
;	 (mapcar
;	  #'car
;	  (remove-if #'(lambda (l) (>= 30 (second l))) lines)))))
;      (write-netpbm
;       (format nil "~~/im/0-~a-1-1.pnm" debug)
;       (mark-grayscale h w oo.s))
;      (format t "WRITE-NETPBM ~a s.~%" (- (get-universal-time) time0))
;      (setf time0 (get-universal-time))
      )
    (let ((nums (locate-numbers 12 oo.s debug)))
      (when debug (format t "LOCATE-NUMBERS ~a s.~%" (- (get-universal-time) time0))
	    (setf time0 (get-universal-time))
	    )
      (let 
	  ((rest
	    (loop for n in nums for i from 1
	       collect
	   (multiple-value-bind (u a) (restore-number n)
	     (let ((r (instantiate-rectangle u))) 
;			(grayscale->graymap! (redundant-number yarg u a))))
;		   (when r
	       (when debug 
		 (write-netpbm 
		  (format nil "~~/im/bad/~a-~a-~a-~a-~a-~a.pnm" 
			  debug i (caar n) (cdar n) (round a)
			  (round (array-dimension r 1) 
				 (array-dimension r 0)))
		  (bitmap->grayscale! (oci::duplicate-image r))))
	       (let ((l (copy-rect 
			 (car 
			  (sort
			   (oci::cut-into-lines
			    (list 0 0 (array-dimension r 0) (array-dimension r 1))
			    r)
			   #'>
			   :key #'(lambda (box)
				    (* (- (third box) (first box))
				       (- (fourth box) (second box))))))
			 r)))
		 (let ((lw (copy-rect 
			    (car 
			     (sort 
			      (cut-into-words l)
			      #'> 
			      :key #'(lambda (box) (- (fourth box) (second box)))))
			    l)))
		   (if (and
			(< 300 (array-total-size lw))
			(<= 4(round (array-dimension lw 1) 
				    (array-dimension lw 0)) 10)
			(<= 0.1 (image-mean lw) 0.5))
		       (progn
			 (when debug 
			   (write-netpbm 
			    (format nil "~~/im/~a-~a-~a-~a-~a-~a.pnm" 
				    debug i (caar n) (cdar n) (round a)
				    (round (array-dimension lw 1) 
					   (array-dimension lw 0)))
			    (bitmap->grayscale! (oci::duplicate-image lw))))
			 (turn-over (observe-number tree lw)))))))))));)
	(when debug (format t "RESTORE&OBSERVE ~a s.~%" (- (get-universal-time) time0))
	      (setf time0 (get-universal-time)))
	(remove-if #'null rest)))))

(defun abovestand (image)
  (let ((imace (chamfer-transform! (image-not image)))
	(r (list 0 0 (array-dimension (cadar *hvigures*) 0)
		 (array-dimension (cadar *hvigures*) 1)))
	(result))
    (dolist (b (list-boxes (array-dimension image 0) (array-dimension image 1)
			   (third r) (fourth r)))
      (dolist (f *hvigures*)
	(let ((d (hr-distance image imace b (second f) (third f) r)))
	  (push 
	   (list (first f) d (new-point (average (first b) (third b))
					(average (second b) (fourth b)))) 
	   result))))
    result))

(defun numero (chars)
  (if chars
      (list
       (format nil "~{~a~}" (mapcar #'car chars))
       (apply #'+ (mapcar #'second chars)))))

(defun get-numero (image) 
  (let ((r (abovestand image)))
    (numero
     (let* ((s (remove-if 
		#'null 
		(unite-middles 
		 (remove-if #'(lambda (e) (>= (second e) 0.75)) r))))
	    (l (length s)))
       (if (= 8 l) s
	   (remove-if 
	    #'null 
	    (unite-middles 
	     (remove-if 
	      #'(lambda (e) (>= (second e) (if (> 8 l) 1.5 0.5))) r))))))))
	  

(defun remove-lines (fac dots)
  (apply 
   #'append 
   (mapcar 
    #'car
    (remove-if 
     #'(lambda (l) (or (null l) (> (second l) (/ 30 fac))))
     (mapcar 
      #'(lambda (l)
	  (if (< 2 (length l))
	      (let ((s (sort-line l))) (list s (oci::sb-length s)))))
      (locate-lines dots))))))

(defun pad-for-hausdorff (image)
  (let ((p (+ (array-dimension image 0) 
	      (array-dimension (second (car *hvigures*)) 0)))
	(p1 (+ (array-dimension image 1) 
	       (array-dimension (second (car *hvigures*)) 1))))
    (let ((lmage (make-array (list p p1) :element-type '(unsigned-byte 8)))
	  (io (floor (- p (array-dimension image 0)) 2))
	  (jo (floor (- p1 (array-dimension image 1)) 2)))
      (dotimes (i (array-dimension image 0) lmage)
	(dotimes (j (array-dimension image 1))
	  (setf (aref lmage (+ i io) (+ j jo)) (aref image i j)))))))

(defun test-red (rect a h w c u o &optional debug)
  (flet ((red-p (e)
	   (and (< 200 (aref a (+ e 2)) 256) ;r
		(< 170 (aref a (+ e 1)) 200) ;g
		(< 160 (aref a (+ e 0)) 190) ;b
		))
	 (blue-p (e)
	   (and (< 50 (aref a (+ e 0)) 256) ;b
		(< 50 (aref a (+ e 1)) 256) ;g
		(< 50 (aref a (+ e 2)) 220) ;r
		)))
    (let ((p (multiple-value-list (oci::rotate-roints u rect))))
      (let ((li (mapcar #'point-i p)) (lj (mapcar #'point-j p)) (count 0)
	    (bcount 0))
	(let ((maxi (min (1- h) (max 0 (+ (point-i o) (apply #'max li)))))
	      (mini (min (1- h) (max 0 (+ (point-i o) (apply #'min li)))))
	      (maxj (min (1- w) (max 0 (+ (point-j o) (apply #'max lj)))))
	      (minj (min (1- w) (max 0 (+ (point-j o) (apply #'min lj))))))
	  (loop for i from mini below maxi do
	       (loop for j from minj below maxj do
		    (let ((e (+ (* i w c) (* j c))))
		      (if (red-p e) (incf count))
		      (if (blue-p e) (incf bcount))
		      )))
	  (when debug 
	    (format 
	     t "TR ~a ~a [~a ~a ~a ~a] ~a ~a~%" 
	     o (round (* 180 (/ u pi))) mini minj maxi maxj bcount count))
	  (if (> bcount (* 50 *rec-num-hor*)) 0 count))))))

(defun decipher-numbers (filename fac &key debug (whine 100) (font 0))
  (hook-numbers font fac) (switch-resolution fac)
  (multiple-value-bind (a h w c) (jpeg:decode-image filename)
    (let* ((size 10) (dots (find-black-text a h w c :div 1))
	   (img (mark-grayscale h w (apply #'append dots) 1))
	   (lns (oci::cut-into-lines (list 0 0 h w) img whine)) (strings)
	   (ramka (mapcar #'(lambda (c) (round c fac)) '(-60 -10 0 10))))
      (loop for l in lns for i from 1 do
	   (when (< size (- (third l) (first l)))
	     (let* ((hl (- (third l) (first l)))
		    (wl (- (fourth l) (second l)))
		    (oy (first l))
		    (ox (second l))
		    (il (mark-grayscale 
			 hl wl
			 (remove-lines
			  fac
			  (oci::image->blacks
			   (copy-rect l img))) 1))
		    (ll (oci::cut-into-lines (list 0 0 hl wl) il whine)))
	       (loop for z in ll for j from 1 do
		    (when (< size (- (third z) (first z)))
		      (let ((ww (cut-into-words il :rect z)))
			(when debug
			  (write-netpbm 
			   (format nil "~~/im/~a-~a-~a-~a.pbm" i j 0 0)
			   (copy-rect z il)))
			(loop for f in ww for k from 1 do
			     (when (and (< size (- (third f) (first f)))
					(< size (- (fourth f) (second f))))
			       (let ((el (copy-rect f il))
				     (oy1 (+ oy (first f)))
				     (ox1 (+ ox (second f))))
				 (when debug
				   (write-netpbm 
				    (format nil "~~/im/~a-~a-~a-~a.pbm" i j k 0)
				    el))
				 (loop for n in 
				      (locate-numbers
				       (/ (* *rec-num-hor* 1.2) fac)
				       (/ (* *rec-num-hor* 1.5) fac)
				       (/ (* *rec-num-hor* 2) fac)
				       (oci::image->blacks el))
				    for q from 1 do
				      (multiple-value-bind (tcr gwgl)
					  (restore-number n)
					(let* ((nr (subseq
						   (multiple-value-list
						    (rect-extents n)) 0 4))
					       (mid
						(new-point
						 (round (+ (first nr)
						  (/ (- (third nr) (first nr)) 
						     2)
						  oy1))
						 (round (+ (second nr)
						    (/ (- (fourth nr) 
							  (second nr))
						       2)
						    ox1))))
					       (red1 (test-red 
						      ramka a h w c gwgl
						      mid debug))
					       (red2 (test-red 
						      ramka a h w c (+ gwgl pi)
						      mid debug))
					       (rct (instantiate-rectangle
						     tcr)))
					  (when debug
					    (format t "RED ~a ~a~%" red1 red2)
					    (write-netpbm 
					     (format nil 
						     "~~/im/~a-~a-~a-~a.pbm" 
						     i j k q)
					     rct))
					  (when
					      (and
					       (or (> red1 30) (> red2 30))
					       (<= 2 (round 
						      (array-dimension rct 1) 
						      (array-dimension rct 0)) 
						   10)
					       (<= 0.1 (image-mean rct) 0.75))
					    (let* ((pid (pad-for-hausdorff rct))
						   (p1d (if (> red1 red2)
							    pid
							    (oci::rotate-image 
							     pid pi)))
						   (ss (get-numero p1d)))
					      (when ss
						(if (> (length (car ss)) 8)
						    (setf
						     ss
						     (let ((oci::*treshold2*
							    (* oci::*treshold2* 
							       1.5)))
						       (get-numero p1d))))
						(push 
						 (append 
						  ss
						  (list
						   (+ (first nr) oy1)
						   (+ (second nr) ox1)
						   (+ (third nr) oy1)
						   (+ (fourth nr) ox1)))
						 strings)
						(when debug
						  (format 
						   t "~a-~a-~a-~a.pbm ~a~%"
						   i j k q (car ss))))
					    ))))))))))))))
      (sort (remove-if-not #'(lambda (s) (< 5 (length (car s)) 11)) strings) 
	    #'string< :key #'car))))