# AggTk

 # extend path for auxiliary libs
lappend auto_path [file join [file dirname [file normalize [info script]]]  lib]


package require snit
package require AggTcl
package require TkPixUtil
package require cobj


 # AggTk widget is simply a frame-widget 
 # without background, i.e. its interior is filled
 # through the blit method that paints the internal rendering buffer (AggTcl)
 # into the window region ..
 
 
 # We strongly assume that 
 #   winfo depth $w  -> 32
 # this is because our internal rendering buffer is built
 # with this structure, in order to get a fast 'blit' (no conversion)


snit::widget AggTk {
	
	typeconstructor {
		 # safety check
		if { [winfo depth .] != 32 } {
			error "FATAL ERROR: AggTk currently only works with 32 bits depth windows."
		}
		 # it is extremely important that AggWin have 'ignored' bg ""
		 #  and no border nor highlight thicknes that may 'invalidate' its contents..
		option add *AggTk.background ""
		option add *AggTk.highlightThickness 0
		option add *AggTk.borderWidth 0
		# ?? padX padY ??
		
		bind AggTk <Configure> {%W _resize %w %h}
		bind AggTk <Expose>    {%W blitDirtyRegion %x %y %w %h}
	}
	
	variable my  ;# array, used for collecting all internal vars ...
		# my(aggObj)    opaque handler to Agg instance
		# my(pixelPtr)  opaque pointer to the rendering buffer ( or "NULL" )
		# my(hDC)       opaque handler to Graphic DC of this widget (constant)
		# my(bmInfo)    opaque handler to bitmap (buffer) header.
	
	delegate option -class  to hull
	delegate option -cursor to hull
	 # Note: for -height, -width options, the standard frame's rule apply:
	 # [..]  Normally -height/-width should not be used if a propagating 
	 # geometry manager, such as grid or pack, is used within the frame since
	 # the geometry manager will override the height of the frame. 
	delegate option -width  to hull
	delegate option -height to hull

	constructor {args} {
		set my(pixelPtr) "NULL"
		set my(bmInfo)   "NULL"
	
		set my(aggObj) [COBJ::NEW  Agg::Agg]
	
		 # save bitmapinfo for the blit method
		 #  (note: it must be updated when bitmap sizes change)
		set my(bmInfo) [tkPix::malloc_BITMAPINFOHEADER]
		if { $my(bmInfo) == "NULL" } {
			error "not enough memory"
		}	
		 # create a raw matrix for rendering buffer
		set w 1 ; set h 1
		set my(pixelPtr) [tkPix::malloc_buffer [expr $w*$h*4]]
		$my(aggObj) attach $my(pixelPtr) $w $h [expr $w*4]		 
		
		set my(hDC) [tkPix::GetDC [winfo id $win]]
	
		 ## ?? clean the buffer ???	
		$my(aggObj) clear white			
	
		$my(aggObj) setUpdateScript [list \
			apply {{w} { after idle [list $w blitAll] ; return }} $win ]
			## To do .. maybe
			## if you know the dirty-region, then use blitDirtyRegion
	}
	
	destructor {
		COBJ::DELETE $my(aggObj)	
		if { $my(pixelPtr) != "NULL" } {
			tkPix::free_buffer $my(pixelPtr)		
		}
		catch {tkPix::ReleaseDC [winfo id $win] $my(hDC)}	
		if { $my(bmInfo) != "NULL" } {
			tkPix::free_BITMAPINFOHEADER $my(bmInfo)		
		}
	}
	
	method getAggHandle {} {
		return $my(aggObj)
	}

	method export {args} {
		set pixmap [$my(aggObj) subImage]
		set res [catch {set photoId [$pixmap export {*}$args]} errMsg]
		COBJ::DELETE $pixmap
		if { $res } {
			error $errMsg
		}
		return $photoId
	}
	method save { filename args } {
		set pixmap [$my(aggObj) subImage]
		set res [catch {$pixmap save $filename {*}$args} errMsg]
		COBJ::DELETE $pixmap
		if { $res } {
			error $errMsg
		}
		return
	}

	method copyto { toPixmap args } {
		set myPixmap [$my(aggObj) subImage]
		set res [catch {$toPixmap copy $myPixmap {*}$args} errMsg]
		COBJ::DELETE $myPixmap
		if { $res } {
			error $errMsg
		}
		return
	}
	
			
	# resize rendering-buffer (by creating a new one and copying the old contents)
	method _resize {w h} {
		set oldPixelPtr $my(pixelPtr)

		# we must copy the old rendering buffer unto the new one ...
		# a) create a temporary Agg::Pixmap with the new size
		# b) get the Agg::Pixmap of $self
		# c) copy the (old) Pixmap in the new buffer 
		# d) destroy the image and the old buffer
		
		 # warning: may raise error (not enough mem)
		set newPixelPtr [tkPix::malloc_buffer [expr $w*$h*4]]
		set newIPixmap [COBJ::NEW Agg::Pixmap]
		$newIPixmap attach $newPixelPtr $w $h [expr $w*4]

		set oldIPixmap [$my(aggObj) subImage] ; # old pixmap is shared !

		 # to do: clean the enlarged regions ..
		$newIPixmap copy $oldIPixmap  ;# note : enlarged regions are not cleared			

		$my(aggObj) attach $newIPixmap ;# this means : attach the related pixel-matrix ...			
		set my(pixelPtr) $newPixelPtr
		
		 # note: destroy only the pixmap-object ( not the referenced pixel-matrix)
		COBJ::DELETE $newIPixmap
		COBJ::DELETE $oldIPixmap

		tkPix::free_buffer $oldPixelPtr

		 # BE CAREFUL: image's height must be inverted ! 
		tkPix::setBITMAPINFOHEADER $my(bmInfo) $w -$h 32
	}
		
	method blitDirtyRegion {x y dx dy} {
		tkPix::blitRegion $my(hDC) $my(pixelPtr) $my(bmInfo) $x $y $dx $dy
		$my(aggObj) updated
	}

	method blitAll {} {
		tkPix::blitAll $my(hDC) $my(pixelPtr) $my(bmInfo)
		$my(aggObj) updated
	}
}



## There's no way to *directly* import images (from graphic files) in AggXX.
## AggXXX can instead use (paint, transform, filter) data from AggPixmaps.
## An AggPixmap is a sort of optimized 'tk-photo', i.e. a matrix of pixel.
## AggPixmap provides several methods for loading/saving photos, as well for
##  exchanging (part of) pixel-matrix with AggXXX   

snit::type AggPixmap {

	#-- some internal utilities: -------------------------------------
	#   GetIntegers
	#   dxdy
	#   Rect2xydxdy
	#   GetImageOpOptions

	 # Scan a list L of 'items', and returns a list with the first numbers (integers) found. 
	 #  
	proc GetIntegers { L } {
		set res {}
		foreach el $L {
			if { $el eq "" } break
			if { ! [string is integer $el] } break
			lappend res $el
		}
		return $res
	}
	 # rect is a valid rectangle {x1 y1 x2 y2}
	 # return a pair {dx dy}
	proc dxdy { rect } {
		lassign $rect x1 y1 x2 y2
		list [expr $x2-$x1] [expr $y2-$y1]
	}
	proc Rect2xydxdy {rect}	 {
		lassign $rect x1 y1 x2 y2
		list $x1 $y1 [expr $x2-$x1] [expr $y2-$y1]
	}	

	 # a rather specialized proc: just for parsing -from, -to options
	 # returns a dictionary with keys -to,-from and 'normalized' coords.
	 # MAY raise errors ..
	 #
	 # ?-from x1 y1 x2 y2?  ?-to x1 y1 x2 y2?
	 #   .. for options -from and -to, see the "photo" manual pages . 
	proc GetImageOpOptions {maxFromRect args} {
		set fromRect $maxFromRect
	   	lassign [dxdy $fromRect] DX DY
	   	set MDX $DX
	   	set MDY $DY
		set toRect {}
			
		set i 0
		while { $i < [llength $args] } {
			set opt [lindex $args $i]
			switch -- $opt {
			   -from {
			   		set fromRect [GetIntegers [lrange $args $i+1 end]]
			   		incr i [llength $fromRect]
			   		if { [llength $fromRect]==2 } {
			   			lassign $fromRect x1 y1		   		
						lappend fromRect $MDX $MDY
					}
					if { [llength $fromRect] != 4 } {
						error "option -from, wrong # args: expected 2 or 4 integers" 	
					}
					lassign $fromRect x1 y1 x2 y2		
					if { $x1 < 0 || $y1 < 0 } {		
						error "option -from, coordinates extend outside the allowed region."				
					}
					if { $x2 > $MDX || $y2 > $MDY } {
						error "option -from, coordinates extend outside the allowed region."				
					}
					if { $x1 > $x2 || $y1 > $y2 }  {
						error "option -from, wrong coordinates: malformed opposite corners." 				 			
					}			
			   		lassign [dxdy $fromRect] DX DY
			   }
			   -to {
				   	set toRect [GetIntegers [lrange $args $i+1 end]]
				   	set n [llength $toRect]
					incr i $n
				   	if { $n == 2 } { 
				   		lassign $toRect x1 y1
						lappend toRect [expr $x1+$DX] [expr $y1+$DY]
						incr n 2
				   	}
				   	if { $n != 4} {
						error "option -to, wrong # args: expected 2 or 4 integers" 			   
					}
					lassign $toRect x1 y1 x2 y2		
					if { $x1 < 0 || $y1 < 0 } {		
						error "option -to, coordinates extend outside the allowed region."				
					}
					if { $x1 > $x2 || $y1 > $y2 }  {
						error "option -to, wrong coordinates: malformed opposite corners." 				 			
					}
			   }
			   default { error "unrecognized option \"$opt\": must be one of : -to, -from"}
			}
			incr i
		}
		
		if { $toRect == {} } {
			set toRect [list 0 0 $DX $DY]
		}
		 
		dict set res -from $fromRect	  
		dict set res -to $toRect
		return $res	  
	} 

	# .. exp, poi commenta ...
	
	proc ExportPhoto {ipix args} {
##		if { [$ipix buf] == "NULL" } return  ??

		set rects [GetImageOpOptions [list 0 0 [$ipix width] [$ipix height]] {*}$args]

		set fromRect [dict get $rects -from]
		set toRect [dict get $rects -to]
		lassign $toRect x1d y1d x2d y2d	
		 # note: may raise error ... (not enough space)
		set photoId [image create photo -width $x2d -height $y2d]

		set subpix [$ipix subImage {*}[Rect2xydxdy $fromRect]]

		tkPix::Tk_Pixmap2Photo \
			[$subpix buf] [$subpix width] [$subpix height] [$subpix stride] \
			{*}[Rect2xydxdy $toRect] \
			$photoId

		COBJ::DELETE $subpix
		return $photoId			
	}	

	variable my
	
	constructor { {W 1} {H 1} } {
		set stride [expr 4*$W]
		set my(pixelPtr) [tkPix::malloc_buffer [expr $H*$stride]]
		if { $my(pixelPtr) == "NULL" } {
			error "not enough memory"
		}
		set my(aggImg) [COBJ::NEW Agg::Pixmap $my(pixelPtr) $W $H $stride]
	}

	destructor {
		if { $my(pixelPtr) != "NULL" } {
			tkPix::free_buffer $my(pixelPtr)
		}
		COBJ::DELETE $my(aggImg)
	}

	
	
	 # the ImageHandle ...
	 # AggTcl methods working with images require an 'image-handle' (not an AggImage object !)
	method getPixmapHandle {} {
		return $my(aggImg)
	}
			
	method height {} { $my(aggImg) height }
	method width {}  { $my(aggImg) width }

	 # 
	 # internal Note: don't create a new PixmapHandle;
	 #   change the old (const) one ! 

	 # return a new AggPixmap
	 # inutile ... fai new + copy
	method xxxclone { fromImg } {
		set im [$type create]
		$im resize [$self width] [$self height]
		[$im getPixmapHandle] copy [$self getPixmapHandle]
		return $im 
	}

	 # note: Pixmap becomes fully transparent !
	method clear {} {
		$my(aggImg) clear
	}
	 # return a photo
	method export {args} {
		ExportPhoto $my(aggImg) {*}$args
	}
	
		
	 # se flag false, non pulisce, ricopia
 	method resize {dx dy {repaint false}} {
 		if { $dx == [$self width]  &&  $dy == [$self height] } return
 		
		set stride [expr 4*$dx]
		set newPixelPtr [tkPix::malloc_buffer [expr $dy*$stride]]
		if { $newPixelPtr == "NULL" } {
			error "not enough memory"
		}		
		if { $repaint } {
			set newAggImage [COBJ::NEW Agg::Pixmap $newPixelPtr $dx $dy $stride]
			 # TODO: clean iff dx or dy is greater than ...
			$newAggImage clear
			$newAggImage copy $my(aggImg)
			COBJ::DELETE $newAggImage			
		}
		tkPix::free_buffer $my(pixelPtr)
		set my(pixelPtr) $newPixelPtr
		$my(aggImg) attach $newPixelPtr $dx $dy $stride 		
	}
	
	 # ?? riesci a rifarla in termini di resize ??
# ma se e' piu' grande, devi pulirla o lasci sporco ?
	method crop {x0 y0 x1 y1} {
	# .. occhio se sono negativi ..
		set dx [expr $x1-$x0]
		set dy [expr $y1-$y0]
		set stride [expr 4*$dx]
		set newPixelPtr [tkPix::malloc_buffer [expr $dy*$stride]]
		set newAggImg [COBJ::NEW  Agg::Pixmap $newPixelPtr $dx $dy $stride]
		 ## if newAggImg is 'greater' than the original, yu must clean the exceeding regions.
		
		set subSrc [$my(aggImg) subImage $x0 $y0 $dx $dy]
		$newAggImg copy $subSrc
		COBJ::DELETE $subSrc
		COBJ::DELETE $newAggImg
		 # note that newPixelBuffer is not deleted ...
		 
		tkPix::free_buffer $my(pixelPtr)
		set my(pixelPtr) $newPixelPtr
		$my(aggImg) attach $newPixelPtr $dx $dy $stride		  		
	}	

	proc MAX {a b} { 
		expr ($a > $b) ? $a : $b 
	}

# ?? e se copia se stessa (con rsize ???)
# ??? ma from img e' un widget	
	method copy { fromImg args } {
		if { [catch {set fromImg [$fromImg getPixmapHandle]}] } {
			error "first arg is not a \"$type\""
		}		
		
		set rects [GetImageOpOptions [list 0 0 [$fromImg width] [$fromImg height]] {*}$args]

		set fromRect [dict get $rects -from]
		set toRect   [dict get $rects -to]
			
		 #eventually resize
		lassign $toRect   x1d y1d x2d y2d	
		$self resize [MAX [$self width] $x2d] [MAX [$self height] $y2d] true
		set subTo [$my(aggImg) subImage {*}[Rect2xydxdy $toRect]]
		set subFrom [$fromImg subImage {*}[Rect2xydxdy $fromRect]]
		$subTo copy $subFrom
		COBJ::DELETE $subFrom		
		COBJ::DELETE $subTo
	}

	 # returns the imageHandle
	 #
	 # May raise an error if photoId does not exist or not-enough-memory
	method import { photoId args } {
		set SDX [image width $photoId]
		set SDY [image height $photoId]

		set rects [GetImageOpOptions [list 0 0 $SDX $SDY] {*}$args]

		set fromRect [dict get $rects -from]
		set toRect   [dict get $rects -to]
			
		 #eventually resize .. note: on error stop
		lassign $toRect   x1d y1d x2d y2d	
		$self resize [MAX [$self width] $x2d] [MAX [$self height] $y2d] true

		 # trick: use photo as a subimage
		array set idata [tkPix::TkPhotoInfo $photoId]		
		set photoImg [COBJ::NEW  Agg::Pixmap]
		$photoImg attach $idata(pixelPtr) $SDX $SDY [expr 4*$SDX]


		set subTo [$my(aggImg) subImage {*}[Rect2xydxdy $toRect]]
		set subFrom [$photoImg subImage {*}[Rect2xydxdy $fromRect]]
		$subTo copy $subFrom
		$subTo swapRxB
		COBJ::DELETE $subTo
		COBJ::DELETE $subFrom		

		COBJ::DELETE $photoImg
		return $my(aggImg)
	}

	# TO DO: work in a thread ...
	method load { filename args } {
		 # on error .. stop
		set photoID [image create photo -file $filename]

		if { [catch {$self import $photoID {*}$args} errMsg] } {
			image delete $photoID
			error $errMSg
		}
		image delete $photoID
		return $my(aggImg)		
	}

	 # -to non ha molto senso ...
	 # l'estensione di filename determina il formato .. 
	method save { filename args } {
		set photoID [$self export {*}$args]
		if { [catch { $photoID write $filename } errMsg] } {
			image delete $photoID
			error $errMSg		
		}
		image delete $photoID
	}
}

	
