; ATTENTION !!!
; unfortunately no catalan support )-: (i made too many typos)
; function and variable names in english
; function semantics differ from the specification
; in the practica sheet
; all functions are triggered from here 
; ---->>>> (defun process-im-wrap(ima &optional (k 1.0) )
; process-im-wrap is commented

; features of programm 

; calculates density
; shows grid over original image
; detects different caracteristica of t9-1 - t10-2
; see  ----->>>>>> (defun test-repet-max(ima)

; developed using dest driven development tecnics
; function trigger(n t)
; can be used to calculate one image (first param) only.
; if the second  paramter if 1 the density of 
; all preceding images are calculated as well and compared
; with previously stored results 
; very practical because one can be shure that a change of
; parameters/algorithms does not affect the result of the
; allready tuned images.
 


; !!!!!!!!!!!!!
; configure amount of output here
; various image/text-outputs can  be tuned


(setq show-maximas 0) ; mark maximums in spectrum
(setq show-maximas-search-area 0) ; show areas where maximums are searched

(setq show-espectre 0) ; display spectrum
(setq show-filter 1) ; display original image whith calculated raster overlaid

; infos over heuristicas used to seperate t9-1 - t10-2

; repetited maxmimas next to x axis are searched
; neighberhoods are calculated to determine areas of maximas
; at least 5 areas need to exist, and they have to be 
; seperated regulary over a range of 50 pixels right from (0 0)

(setq show-neighbour-info 0) 
(setq show-neighbour-region 0)
(setq show-neighbour-region-text 0)


; debugging output
(setq debuk 0)

; end settings
; !!!!!!!!!!!!!

(load "display.lsp")

(setq ncol-orig 640)
(setq nlin-orig 480)
(setq mm-per-pixel-x 0.0234)
(setq mm-per-pixel-y 0.0243)

(setq llista-noms (list 
"imatges/t1-1.tif"
"imatges/t1-2.tif"
"imatges/t2-1.tif"
"imatges/t2-2.tif"
"imatges/t3-1.tif"
"imatges/t3-2.tif"
"imatges/t4-1.tif"
"imatges/t4-2.tif"
"imatges/t5-1.tif"
"imatges/t5-2.tif"
"imatges/t6-1.tif"
"imatges/t6-2.tif"
"imatges/t7-1.tif"
"imatges/t7-2.tif"
"imatges/t8-1.tif"
"imatges/t8-2.tif"
"imatges/t9-1.tif"
"imatges/t9-2.tif"
"imatges/t10-1.tif"
"imatges/t10-2.tif"
))



(setq no-out 0)

;          +----------------------------------------------+
;          |                         "A ma"               |
;          |    Nom  Fils trama  Fils urdit  Fils totals  |
;          +----------------------------------------------+
(setq fils-reals (list 
      (list    't1-1     15          16           31      )
      (list    't1-2     14          17           31      )
      (list    't2-1     14          22           36      )
      (list    't2-2     16          23           39      )
      (list    't3-1     16          15           31      )
      (list    't3-2     15          15           30      )
      (list    't4-1     16          14           30      )
      (list    't4-2     16          15           31      )
      (list    't5-1     16          13           29      )
      (list    't5-2     16          14           30      )
      (list    't6-1     23          23           46      )
      (list    't6-2     22          23           45      )
      (list    't7-1     13          22           35      )
      (list    't7-2     13          21           34      )
      (list    't8-1     20          26           46      )
      (list    't8-2     19          27           46      )
      (list    't9-1      0          13           13      )
      (list    't9-2      0          13           13      )
      (list    't10-1     0          11           11      )
      (list    't10-2     0          12           12      )
                  )
)

;; Wrapper Functions for catalan Support

(defun ComptaFils(str)
  (process-im str )
)

(defun process-im(str )
  (if (eql no-out 0)
  (print (strcat "processing image: " str))
  )
  (process-im-wrap (readi str) 0.0001 )
)

(defun readi(ima)
   (- 255 (readim ima ncol-orig nlin-orig))
)
(defun int-real(int)
  (* int 1.0)
)
(defun gdr(ima)
   (setq piece (getim ima 0 (- 480 32) 511 479) )
   (setq bigpiece (getim ima 0 0 511 479))
   (addlin bigpiece piece)
)
(defun cut-center(ima)
  (getim ima 200 200 300 300)
)
(defun Densitat(nombrefils)
   (setq areaima (* (* mm-per-pixel-x ncol-orig) (* mm-per-pixel-y nlin-orig)))
   (/ nombrefils areaima)
)


(defun mark-maximum-wrap(ima coordinates)

 (setq q1 (first coordinates))
 (setq q2 (first (rest coordinates)))

 (setq ima (mark-maximum ima q1))
 (setq ima (mark-maximum ima q2))

 ima
)

(defun mark-maximum(ima coo)
  (setq x (+ 256 (first coo)))
  (setq y (+ 256 (first (rest coo))))

  (setq ima2 (imcpy ima))

  (putpixel ima2 (- x 2) (- y 2) 255 )
  (putpixel ima2 (- x 1) (- y 2) 255 )
  (putpixel ima2 (- x 0) (- y 2) 255 )
  (putpixel ima2 (+ x 1) (- y 2) 255 )
  (putpixel ima2 (+ x 2) (- y 2) 255 )

  (putpixel ima2 (- x 2) (- y 1) 255 )
  (putpixel ima2 (+ x 2) (- y 1) 255 )

  (putpixel ima2 (- x 2) (- y 0) 255 )
  (putpixel ima2 (+ x 2) (- y 0) 255 )

  (putpixel ima2 (- x 2) (+ y 1) 255 )
  (putpixel ima2 (+ x 2) (+ y 1) 255 )

  (putpixel ima2 (- x 2) (+ y 2) 255 )
  (putpixel ima2 (- x 1) (+ y 2) 255 )
  (putpixel ima2 (- x 0) (+ y 2) 255 )
  (putpixel ima2 (+ x 1) (+ y 2) 255 )
  (putpixel ima2 (+ x 2) (+ y 2) 255 )

  ima2
)


(defun findmax(ima )
; XXX stupid implementation
; XXX at least insert break when
; XXX maxval found

   (if 
     (eql debuk 1)
     (print "findmax")
   )

   (setq maxval (maxpix ima))
   (setq resx (- (ImNCol ima) 1 ))
   (setq resy (- (ImNLin ima) 1 ))

   (setq result (list))

   (setq found 0)

   (do
     ( (i resx (setq i (- i 1) ) ) )
     ( (eql i -1) )
     (do
        ( (j resy (setq j (- j 1) ) ))
        ( (eql j -1) )
	;(princ i)
	;(princ " ")
	;(print j)
        (if 
          (eql maxval (getpixel ima i j))
          (setq result (list i j))
;          (if 
;	    (eql found 0)
;	    (and (setq result (list i j)) (setq found (+ found 1)) )
;            (setq found (+ found 1))
;	  )
	)
      )
    )
   (cond ( (eql no-out 0 )

   (cond ((eql show-maximas-search-area 1) 
         (princ "findmax ")
         (princ maxval)
         (princ " ") 
         (print result)
         (dw ima) 
      ))
   ))
   ;(if (eql no-out 0)
   ;  (and (and (and (and (princ "findmax ") (princ maxval) ) (princ " ") ) (print result) ) (dw ima) )
   ;)
   result
)

(defun espectra(ima)
   (if 
     (eql debuk 1)
     (print "espectra")
   )

   (setq ff_re (complextore ima)) 
   (setq ff_im (complextoim ima)) 

   (sqrtim (+ (* ff_re ff_re) (* ff_im ff_im) ) )
)


(defun espectra-display(ima k)
   (if 
     (eql debuk 1)
     (print "espectra-display")
   )
   (maxcon (invqua (logim (+ 1.0 (* k ima )))))
)

; x0 y1 diferencia del origen
; dx dy tamano del subimagen
(defun searchpic-wrap(ima x0 y0 dx dy)
   (if 
     (eql debuk 1)
     (print "searchpic-wrap")
   )
  ; la mitat
  (setq lm (/ (ImNCol ima) 2))
  (setq result 
	(searchpic ima (+ lm x0) (+ lm y0) (+ lm x0 dx) (+ lm y0 dy) )
  )
  (setq res (list (- (first result) lm ) (- (first (rest result)) lm )))
  res
)


(defun searchpic(ima x0 y0 x1 y1)
   (if 
     (eql debuk 1)
     (print "searchpic")
   )
  (setq temp (getim ima x0 y0 x1 y1))
  (setq result (findmax temp))
  (setq res (list (+ x0 (first result)) (+ y0 (first (rest result))) ))
  res
)

   ; contado per mano

   ; t1-1 (56 41)   (69 56)
   ; t1-2 (57 41)   (69 56)
   ; t2-1 (54 42)   (69 54) oder (74 58)
   ; t2-2 (55 42)   (69 54) oder (74 58)
   ; t3-1 (56 39)   (64 61)
   ; t3-2 (56 40)   (64 61)
   ; t4-1 (56 39)   (64 59)
   ; t4-2 (56 40)   (65 60)
   ; t5-1 (56 39)   (64 52)
   ; t5-2 (56 39)   (64 52)
   ; t6-1 (56 44)  oder schreag (62 48)  (74 56)
   ; t6-2 (56 44)  oder schreag (62 49)  (74 56)
   ; t7-1 (56 42)   (73 55)
   ; t7-2 (56 42)   (73 56)
   ; t8-1 (56 35)   (77 55)
   ; t8-2 (56 35) oder (56 46) (77 55)

   ; trabacho

   ; t1-1 (56 41)   (69 56)
   ; t1-2 (57 41)   (69 56)
   ; t2-1 (54 42)   (69 54) 
   ; t2-2 (55 42)   (69 54)
   ; t3-1 (56 39)   (64 61)
   ; t3-2 (56 40)   (64 61)
   ; t4-1 (56 39)   (64 59)
   ; t4-2 (56 40)   (65 60)
   ; t5-1 (56 39)   (64 52)
   ; t5-2 (56 39)   (64 52)
   ; t6-1 (56 44)   (74 56)
   ; t6-2 (56 44)   (74 56)
   ; t7-1 (56 42)   (73 55)
   ; t7-2 (56 42)   (73 56)
   ; t8-1 (56 35)   (77 55)
   ; t8-2 (56 35)   (77 55)



;0 -15 13 0
;1 -15 13 0
;-2 -14 13 -2 
;-1 -14 13 -2 
;0 -17 8 5 
;0 -16 8 5 
;0 -17 8 3 
;0 -16 9 4
;0 -17 8 -4 
;0 -17 8 -4 
;0 -12 18 0  XXX
;0 -12 18 0 
;0 -14 17 -1 
;0 -14 17 0 
;0 -21 21 -1 
;0 -21 21 -1

(defun search-quadrants(ima)
   (if 
     (eql debuk 1)
     (print "search-quadrants")
   )


   ; rectanlgular coordinate definitions
   ; !!!! differ from specification !!!!!!

   ; first two parameters upper left corner in respect to ( 256 256)
   ; next two parameters size in x and y direction
  (setq q1 (searchpic-wrap ima -2 -23 3 9))
  (setq q2 (searchpic-wrap ima 8 -1 13 6))

   (cond ( (eql no-out 0 )

   (cond ((eql show-maximas-search-area 1) 
      (princ "quadrant 1: ")
      (print q1)
      (princ "quadrant 2: ") 
      (print q2)
      ))
   ))
  (list q1 q2)
)


; !!!!!!!!!!!!!
; implementation distinto 
; variable fftima no es estado del imgen despues de fft
; pero antes
; !!!!!!!!!!!!!
(defun invers(fftima coordinates)

  (if 
    (eql debuk 1)
    (print "iinvers")
  )

 (setq resx  (ImNCol fftima) )
 (setq resy  (ImNLin fftima) )

 (setq q1 (first coordinates))
 (setq q2 (first (rest coordinates)))

 (setq lm (/ resx 2))

 (setq f-t (image resx resx))
 (setq f-u (image resx resx))

 (putpixel f-t lm lm 255)
 (putpixel f-u lm lm 255)
 (putpixel f-t (+ lm (first q1)) (+ lm (first (rest q1))) 255)
 (putpixel f-u (+ lm (first q2)) (+ lm (first (rest q2))) 255)

 (setq temp (imtocomplex (invqua f-t)))
 (setq temp (fft_1 temp))
 (setq temp (complextore temp))
 (setq temp (maxcon temp))

 (setq temp2 (imtocomplex (invqua f-u)))
 (setq temp2 (fft_1 temp2))
 (setq temp2 (complextore temp2))
 (setq temp2 (maxcon temp2))

 (setq res (max (thr temp 250) (thr temp2 250 )))

 res 
)

(defun sumlist(li)
  (setq sum 0)
  (mapcar (lambda (el)
	    (setq sum (+ sum  el))
	    )
	  li
  )
  sum
)

(defun dupelim(li)
  (setq res (list))

  (delete NIL (mapcar (lambda (el)
	    (cond ((member el res :test 'EQUAL)  NIL ) ( 
		(not NIL)
		(setq res (append res (list el )) ) 
	    ))) li
   ))
  res
)

(defun test-repet-max(ima)
  (setq trozo (getim ima 260 253 310 257) )

  (setq t1 (thr (getim trozo 0 0 11 4) 97 ))
  (setq t2 (thr (getim trozo 12 0 21 4) 100))
  (setq t3 (thr (getim trozo 22 0 30 4) 95 ))
  (setq t4 (thr (getim trozo 31 0 39 4) 85 ))
  (setq t5 (thr (getim trozo 40 0 50 4) 70 ))

  (setq trozo (addcol t1 t2 t3 t4 t5))
  (setq neib (built-neighbours trozo))

  (cond ( (eql no-out 0 ) 
   (cond ((eql show-neighbour-region 1) (dw trozo)))
  ))

  (setq neib (delete NIL (mapcar 
          (lambda (le)  
	    (cond
	      ( (or (eql (length le) 1) (> (length le) 65 ) ) NIL )
	      ( (not NIL) le )
	    )
          )
         neib 
       ) :test 'EQUAL)
  )

  (setq anzelem (mapcar 'length neib))
  (setq median (sumlist anzelem))

   (cond ( (eql no-out 0 )

   (cond ((eql show-neighbour-region-text 1) 
      (show-groups neib)
      (princ "grupo tamano: ")
      (print gsize)
      ))
   ))

  (setq gsize (length neib))
  
  (cond
    (  (> gsize 4) ( heuristik ) )
    ( (not NIL) NIL )
  )
)

(defun heuristik()
  
  (setq t11 (getim trozo 0 0 25 4) )
  (setq t22 (getim trozo 26 0 50 4) )

  (setq  n11 (built-neighbours t11))
  (setq  n22 (built-neighbours t22))

  (setq anzelem11 (mapcar 'length n11))
  (setq median11 (sumlist anzelem11))

  (setq anzelem22 (mapcar 'length n22))
  (setq median22 (sumlist anzelem22))
  (setq qq (/ median22 (* 1.0 median11)))

   (cond ( (eql no-out 0 )

   (cond ((eql show-neighbour-info 1) 
	(print "repetited maximum detected, applying heuristica")
        (princ "first region: ")
        (print median11)
        (princ "second region: ")
        (print median22)
        (princ "quotient: ")
        (print qq)
      ))
   ))

  (cond (
	  (> qq 0.4 ) 
          (if (eql no-out 0)
             (print "    ---   exclusion detected, setting q1 (0 0)")
           ) (eql 1 1)
	)
        ((not NIL) NIL)
  )
)

(defun built-neighbours(ima)
   (setq resx (ImNCol ima) )
   (setq resy (ImNLin ima) )

   (setq neib (list))

   (do
     ((i 0 (setq i (+ i 1) )))
     ((eql i resx))

     (do
       ((j 0 (setq j (+ j 1) )))
       ((eql j resy))
       ; start
	(setq pw (getpixel ima i j))

       (cond
       ( (eql pw 255) 
	 
       (setq w
       (delete 'NIL (mapcar 
          (lambda (le)  
            (cond (
		 (eql (getpixel ima (nth 0 le) (nth 1 le) ) 255 )
		 (list (nth 0 le ) (nth 1 le) )
		) 
         	( (not NIL) NIL)
            )) (get-neighbours resx resy i j)
       )))

       ; w enthaelt alle nachbarn von (i j) die weiss sind

       ; (i j) in die gruppe der nachbarn von (i j) aufnehmen
       ; alle gruppen finden, (i j) hinzufuegen 
       ; uU vereinigen

          (cond ( w (setq neib (multi1 neib w i j)))
           ((not NIL) 
   	   (setq neib (append neib (list (list (list i j)))))
          )) 
       ) ; end cond action
       ) ; end cond
     )) neib
)

(defun show-groups(l)
       (mapcar (lambda (le)  
	    (setq len (length le))
	    (princ "un grupo [")
	    (print len)
	    (print le)
       )l)
)

; a1 := ( ((a b)) ((c d) (e f) ) )
; a2 := ( (x y) (t y) )

; fuer alle nachbarn rausfinden in welcher gruppe sie sind (multilist)
; (sie koennen nur in einer sein). 
; (i j) in die Gruppe hinzufuegen
; wenn mehrere nachbarn alle zu einer gruppe verschmelzen

(defun multi1(a1 a2 i j)

  ;(print "multi1 anf")
  ;(print a1)
  ;(print a2)
  ;(print (list i j))

  (setq subl (list ))
  (setq arg1 a1)

  (defun doitm(arg2)
    (setq yy (multilist arg1 arg2))
    (delete yy arg1 :test 'EQUAL)
    (setq subl 
	  (dupelim (append subl (append (list (list i j)) yy) )) )
  )

  (mapcar 'doitm a2)
  (setq arg1 (append arg1 (list subl) ))
  arg1
)

(defun multilist(a b)
  ; a:= ( ((a b)) ((c d) (e f) ) )
  ; b:= (e f)

  (defun doit(arg2)
    (if (member temp arg2 :test 'EQUAL) arg2 NIL)
  )

  (setq temp b)
  (first (delete NIL (mapcar 'doit a)))

)

(defun get-neighbours(resx resy x y)
  ; TODO add parameter for neighbourhood defintion
  (setq mx (- x 1))
  (setq px (+ x 1))
  (setq my (- y 1))
  (setq py (+ y 1))

  (defun elim-neg(arg)
    (cond 
      ((< (nth 0 arg) 0 )  NIL )
      ((< (nth 1 arg) 0 )  NIL )
      ((eql resx (nth 0 arg)) NIL )
      ((eql resy (nth 1 arg)) NIL )
      ( (not NIL) arg )
    )
  )

  (setq res (list (list mx my) (list x  my) (list mx y) (list mx py)))
  (delete 'NIL (mapcar 'elim-neg res))
)

(defun process-im-wrap(ima &optional (k 1.0) )

  ( if (eql no-out 0)

  (if (eql debuk 1) (print "process-im-wrap")))


   ; calculate various image representations
   (setq my_im (gdr ima))
   (setq cplx_im (imtocomplex my_im) )
   (setq fft_im (fft cplx_im))  
   (setq fft_im_es (espectra fft_im))
   (setq fft_im_es_di (espectra-display fft_im_es k))

   ; test for repetited maximums (t9-1 - t10-2)
   (setq repet (test-repet-max fft_im_es_di) )

   ; search maximas
   (setq coordinates (search-quadrants fft_im_es_di))

   ; alter coordinates in case of t9-1 - t10-2
   (cond ( repet
       (setq coordinates (list (list 0 0) (nth 1 coordinates) )) 
   ))

   ; calculate nicer image representations 

   ; spectrum with marked maximas
   (setq fft_im_es_di_mark 
	 (mark-maximum-wrap fft_im_es_di coordinates)
   )
   ; original image with calculated grid
   (setq grid (invers fft_im coordinates))

   ; calculate distance from origin
   (setq q1 (mapcar 'abs (nth 0 coordinates) ) )
   (setq q2 (mapcar 'abs (nth 1 coordinates) ) )

   (setq d1 (+ (nth 0 q1) (nth 1 q1)))
   (setq d2 (+ (nth 0 q2) (nth 1 q2)))

   ; output info if desired
   (cond ( (eql no-out 0 )

   (cond ((or (eql show-maximas 1) (eql show-maximas-search-area 1) ) 
	  (dw (cut-center fft_im_es_di_mark))))
   (cond ((eql show-espectre 1) (dw (cut-center fft_im_es_di))))
   (cond ((eql show-filter 1) (dw (maxcon (max my_im grid)))))

   ))

   (list d1 d2 (+ d1 d2) (Densitat (+ d1 d2) ))
)



(defun extreeeme(n)

  (setq no-out 1)
  

  (setq resxg (list 28 29 36 35 30 28 28 29 31 31
	  41 41 32 31 43 43 10 10 9 10))

  (if (> n (length resxg))
    (print "TEST Hinzuefuegen")
  )

  (do
    ((i 0 (setq i (+ i 1))))
    ((eql i n))
    (setq aa (nth i resxg))
    (setq bb ( nth 2 (process-im (nth i llista-noms )  )))
    ( if 
      (not (eql aa bb ))
      (and (and (and (princ "FEHLER IN") (print i) ) (princ "soll-ist: ") ) (print (list aa bb )  ) )
      ;(and (princ "KEIN FEHLER IN") (print i))
    )
  )
  (setq no-out 0)
)

(defun trigger(z ttt)

   (if (eql ttt 1)
   ( extreeeme z)
   )
   (setq fils-calculats (ComptaFils (nth z llista-noms)))
   (setq taula-resultats (append (nth z fils-reals) fils-calculats))
   (pprint taula-resultats)

)

; if extra info desired uncomment coresponding lines
; will apear in informe
(defun filter-resultats(l)
	(append 
		l
		;(list (abs (- (nth 3 l) (nth 6 l))) )
		;(list (abs (- (nth 1 l) (nth 4 l))) )
		;(list (abs (- (nth 2 l) (nth 5 l))) )
		;(list (+
		;(abs (- (nth 1 l) (nth 4 l))) 
		;(abs (- (nth 2 l) (nth 5 l))) 
		;))
	)
)

(defun all()
   (setq fils-calculats (mapcar 'ComptaFils llista-noms))
   (setq taula-resultats (mapcar 'append fils-reals fils-calculats  ))
   (setq taula-resultats (mapcar 'filter-resultats  taula-resultats ))
   (pprint taula-resultats)
)


;main
;(chdir "d:/imatges/practica1")

; DO_IT!!!!
(all)