#!/usr/bin/perl -w

#
# Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full
# list)
# 
# This library is free software; you can redistribute it and/or modify it under
# the terms of the GNU Library General Public License as published by the Free
# Software Foundation; either version 2.1 of the License, or (at your option)
# any later version.
# 
# This library is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
# more details.
# 
# You should have received a copy of the GNU Library General Public License
# along with this library; if not, write to the Free Software Foundation, Inc.,
# 59 Temple Place - Suite 330, Boston, MA  02111-1307  USA.
#
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/examples/histogramplot.pl,v 1.8 2003/10/19 04:42:44 muppetman Exp $
#

# originally written in C by muppet in 2001 or 2002, i can't remember.
# ported from C to gtk2-perl 2003 by muppet

package Histogram::Plot;

use Gtk2;
use warnings;
use strict;
use Data::Dumper;

use constant FALSE => 0;
use constant TRUE => 1;

use constant MIN_CHART_WIDTH  => 256;
use constant MIN_CHART_HEIGHT => 100;

my %drag_info;
use constant DRAG_PAD => 2;

sub screen_to_threshold {
	my ($plot, $sx) = @_;
	my $val = ($sx - $plot->{chartleft}) * 256 / $plot->{chartwidth};
	return $val < 0 ? 0 : $val > 255 ? 255 : $val;
}
sub threshold_to_screen {
	$_[1] / 256.0 * $_[0]->{chartwidth} + $_[0]->{chartleft}
}


#
# Glib::Objects are special; they're not normal perl objects (although
# the bindings go out of their way to make them act like it).
#
# if you just want to add a new function for yourself to a Gtk2::DrawingArea,
# the stuff we're about to get into is not strictly necessary; you could just
# re-bless the object reference into the decendent class and add an @ISA for
# it, like normal perl.
#
# however, adding signals, properties, or virtual function overrides to a
# GObject-based class requires fiddling with a GObjectClass structure
# specific to that subclass.  if you added a new property to a re-blessed
# Glib::Object, *all* instances of that reblessed object's GObject parent
# would have the new property!  that's because you didn't create a new
# GObjectClass for that new subclass.
#
# in order to create a new type to which you can add signals and properties,
# and which will be indistinguishable from "normal" GObjects at the C level
# (which means you can pass it to other gtk functions), you need to 
# register your subclass with the Glib::Type subsystem.
#
# here, we're registering the current package as a new subclass of
# Gtk2::DrawingArea, and in the process adding a signal and a few
# object properties.
#
use Glib::Object::Subclass
	'Gtk2::DrawingArea',
	signals => {
		#
		# create a new signal...
		#
		threshold_changed => {
			method      => 'do_threshold_changed',
			flags       => [qw/run-first/],
			return_type => undef, # void return
			param_types => [], # instance and data are automatic
		},
		#
		# override some built-ins...  note that for this to work
		# there has to be a signal to go along with the virtual
		# function you want to override...
		#
		# i chose do_size_request to keep from having the normal
		# size_request method being called.
		size_request => \&do_size_request,
		# just to show it off...  you can use names, but you have
		# to use a qualified name, or it looks in the current package
		# at runtime, not setup time.
		expose_event => __PACKAGE__.'::expose_event',
		configure_event => \&configure_event,
		motion_notify_event => \&motion_notify_event,
		button_press_event => \&button_press_event,
		button_release_event => \&button_release_event,
	},
	properties => [
		Glib::ParamSpec->double ('threshold',
		                         'Threshold',
		                         'Diving line between above and below',
		                          0.0, 255.0, 127.0,
		                         [qw/readable writable/]),
		Glib::ParamSpec->boxed ('histogram',
		                        'Histogram Data',
		                        'Array reference containing histogram data',
		                        'Glib::Scalar',
		                        [qw/readable writable/]),
		Glib::ParamSpec->boolean ('continuous',
		                          'Continuous updates',
		                          'Emit the threshold_changed signal on every mouse event during drag, rather than just on release',
		                          FALSE,
		                          [qw/readable writable/]),
	],
;

#
# at the lowest level, new Glib::Objects are created by Glib::Object::new.
# that function creates the instance and calls the instance initializers
# for all classes in the object's lineage, from the parent to the descendant.
# if there's any setup you would need to do in a constructor, it goes here.
#
sub INIT_INSTANCE {
	my $plot = shift;
	warn "INIT_INSTANCE $plot";

	$plot->{threshold}       = 0;
	$plot->{histogram}       = [ 0..255 ];
	$plot->{pixmap}          = undef;
	$plot->{th_gc}           = undef;
	$plot->{dragging}        = FALSE;
	$plot->{continuous}      = FALSE;
	$plot->{origin_layout}   = $plot->create_pango_layout ("0.0%");
	$plot->{maxval_layout}   = $plot->create_pango_layout ("100.0%");
	$plot->{current_layout}  = $plot->create_pango_layout ("0");
	$plot->{maxscale_layout} = $plot->create_pango_layout ("255");
	$plot->{minscale_layout} = $plot->create_pango_layout ("0");
	$plot->{max}             = 0;

	$plot->{chartwidth}      = 0;
	$plot->{chartleft}       = 0;
	$plot->{bottom}          = 0;
	$plot->{height}          = 0;

	$plot->set_events ([qw/exposure-mask
			       leave-notify-mask
			       button-press-mask
			       button-release-mask
			       pointer-motion-mask
			       pointer-motion-hint-mask/]);
}


#
# whenever anybody tries to get the value of a gobject property belonging
# to this class, this function will be called.  note that this call
# signature is different from the C version -- here we return the requested
# value.
#
sub GET_PROPERTY {
	my ($plot, $pspec) = @_;
	if ($pspec->get_name eq 'threshold') {
		return $plot->{threshold};
	} elsif ($pspec->get_name eq 'histogram') {
		return $plot->{histogram};
	} elsif ($pspec->get_name eq 'continuous') {
		return $plot->{continuous};
	}
}

#
# whenever anybody tries to set the value of a gobject property belonging
# to this class, this function will be called.  the provided Glib::Object::Base
# method just stores the value in a hash key, but here we need to do other
# bits of work when a value is changed.
#
# note that this one also is changed from the C call signature; the order
# of the arguments has been swizzled to be more consistent with GET_PROPERTY.
#
sub SET_PROPERTY {
	my ($plot, $pspec, $newval) = @_;
	if ($pspec->get_name eq 'threshold') {
		$plot->set_plot_data ($newval, ());
	} elsif ($pspec->get_name eq 'histogram') {
		$plot->set_plot_data (undef, @$newval);
	} elsif ($pspec->get_name eq 'continuous') {
		$plot->{continuous} = $newval;
	}
}


sub calc_dims {
	my $plot = shift;

	my $context = $plot->{origin_layout}->get_context;
	my $fontdesc = $context->get_font_description;
	my $metrics = $context->get_metrics ($fontdesc, undef);

	$plot->{textwidth} = 5 * $metrics->get_approximate_digit_width
			   / Gtk2::Pango->scale; #PANGO_SCALE;
	$plot->{textheight} = ($metrics->get_descent + $metrics->get_ascent)
		            / Gtk2::Pango->scale; #PANGO_SCALE;
	
	$plot->{chartleft} = $plot->{textwidth} + 2;
	$plot->{chartwidth} = $plot->allocation->width - $plot->{chartleft};
	$plot->{bottom} = $plot->allocation->height - $plot->{textheight} - 3;
	$plot->{height} = $plot->{bottom};
}

# this gets called when the widget's parent container wants to know
# how much space we want.  it's important to note that this sub will be
# called from deep within the gtk library, not from perl code, which is
# why it had to be implemented as a class closure override.
# we modify the requisition passed to us.
sub do_size_request {
	my ($plot, $requisition) = @_;
	warn "in class override for $_[0]\::do_size_request";

	$requisition->width ($plot->{textwidth} + 2 + MIN_CHART_WIDTH);
	$requisition->height ($plot->{textheight} + MIN_CHART_HEIGHT);

	# chain up to the parent class.
	shift->signal_chain_from_overridden (@_);
}


sub expose_event {
	my ($plot, $event) = @_;

	$plot->window->draw_drawable ($plot->style->fg_gc($plot->state),
				      $plot->{pixmap},
				      $event->area->x, $event->area->y,
				      $event->area->x, $event->area->y,
				      $event->area->width, $event->area->height);
	return FALSE;
}

sub configure_event {
	my ($plot, $event) = @_;

	$plot->{pixmap} = Gtk2::Gdk::Pixmap->new ($plot->window,
	                                          $plot->allocation->width,
	                                          $plot->allocation->height,
	                                          -1); # same depth as window

	# update dims
	$plot->calc_dims;

	$plot->histogram_draw;

	return TRUE;
}

sub draw_th_marker {
	my ($plot, $w, $draw_text) = @_;

	if (!$plot->{th_gc}) {
		$plot->{th_gc} = Gtk2::Gdk::GC->new ($plot->{pixmap});
		$plot->{th_gc}->copy ($plot->style->fg_gc ($plot->state));
		$plot->{th_gc}->set_function ('invert');
	}
	$w->draw_line ($plot->{th_gc},
		       $plot->threshold_to_screen ($plot->{threshold}), 0,
		       $plot->threshold_to_screen ($plot->{threshold}), $plot->{bottom});

	$plot->{current_layout}->set_text (sprintf '%d', $plot->{threshold});
	my ($textwidth, $textheight) = $plot->{current_layout}->get_pixel_size;
	$plot->{marker_textwidth} = $textwidth;

	# erase text
	$w->draw_rectangle ($plot->style->bg_gc($plot->state), 
			    TRUE,
			    $plot->threshold_to_screen ($plot->{threshold})
			    	- $plot->{marker_textwidth} - 1,
			    $plot->{bottom} + 1,
			    $plot->{marker_textwidth} + 1,
			    $textheight);

	$w->draw_layout ($plot->{th_gc}, 
			 $plot->threshold_to_screen ($plot->{threshold})
				 	- $plot->{marker_textwidth},
				 $plot->{bottom} + 1,
				 $plot->{current_layout})
		if $draw_text;
}

#
# the user can click either very near the vertical line of the marker
# or on (actually in the bbox of) the marker text.
#
sub marker_hit {
	my ($plot, $screen_x, $screen_y) = @_;

	my $screen_th = $plot->threshold_to_screen ($plot->{threshold});
	if ($screen_y > $plot->{bottom}) {
		# check for hit on text
		if ($screen_x > $screen_th - $plot->{marker_textwidth} &&
		    $screen_x <= $screen_th) {
			return $screen_th;
		}
	} else {
		# check for hit on line
		if ($screen_x > $screen_th - DRAG_PAD &&
		    $screen_x < $screen_th + DRAG_PAD) {
			return $screen_th;
		}
	}
	return undef;
}

sub button_press_event {
	my ($plot, $event) = @_;

	return FALSE
		if ($event->button != 1 || not defined $plot->{pixmap});

	my $sx = $plot->marker_hit ($event->x, $event->y);
	return FALSE
		unless defined $sx;

	# erase the previous threshold line from the pixmap...
	$plot->{threshold_back} = $plot->{threshold};
	$plot->draw_th_marker ($plot->{pixmap}, FALSE);
	$plot->window->draw_drawable ($plot->style->fg_gc($plot->state),
				      $plot->{pixmap},
			$plot->threshold_to_screen ($plot->{threshold}) - $plot->{marker_textwidth}, 0,
			$plot->threshold_to_screen ($plot->{threshold}) - $plot->{marker_textwidth}, 0,
			$plot->{marker_textwidth} + 1, $plot->allocation->height);
	# and draw the new one on the window.
	$plot->draw_th_marker ($plot->window, TRUE);
	$plot->{dragging} = TRUE;

	$drag_info{offset_x} = 
		$plot->threshold_to_screen ($plot->{threshold}) - $event->x;

	return TRUE;
}

sub button_release_event {
	my ($plot, $event) = @_;

	return FALSE
		if ($event->button != 1 
		    || !$plot->{dragging}
		    || not defined $plot->{pixmap});

	# erase the previous threshold line from the window...
	$plot->draw_th_marker ($plot->window, FALSE);
	$plot->{threshold} = 
		$plot->screen_to_threshold ($event->x + $drag_info{offset_x});
	# and draw the new one on the pixmap.
	$plot->draw_th_marker ($plot->{pixmap}, TRUE);
	$plot->window->draw_drawable ($plot->style->fg_gc ($plot->state),
				      $plot->{pixmap},
				      0, 0, 0, 0,
				      $plot->allocation->width,
				      $plot->allocation->height);
	$plot->{dragging} = FALSE;

	# let any listeners know that if the threshold has changed
	$plot->signal_emit ("threshold-changed")
		if $plot->{threshold_back} != $plot->{threshold}
		   and not $plot->{continuous};

	return TRUE;
}

my $sizer;

sub motion_notify_event {
	my ($plot, $event) = @_;

	my ($x, $y, $state);

	if ($event->is_hint) {
		(undef, $x, $y, $state) = $event->window->get_pointer;
	} else {
		$x = $event->x;
		$y = $event->y;
		$state = $event->state;
	}
	if ($plot->{dragging}) {
		return FALSE
			if (!(grep /button1-mask/, @$state) ||
			    not defined $plot->{pixmap});
		
		$plot->draw_th_marker ($plot->window, FALSE);
		
		$x += $drag_info{offset_x};
		
		# confine to valid region
		my $t = $plot->screen_to_threshold ($x);
		$x = $plot->threshold_to_screen (0) if $t < 0;
		$x = $plot->threshold_to_screen (255) if $t > 255;
		
		$plot->{threshold} = $plot->screen_to_threshold ($x);
		$plot->draw_th_marker ($plot->window, TRUE);

		$plot->signal_emit ("threshold-changed")
			if $plot->{continuous};

	} else {
		my $c = undef;
		my $sx = $plot->marker_hit ($x, $y);
		if (defined $sx) {
			$sizer = Gtk2::Gdk::Cursor->new ('GDK_SB_H_DOUBLE_ARROW')
				if not defined $sizer;
			$c = $sizer;
		}
		$plot->window->set_cursor ($c);
	}

	return TRUE;
}



sub histogram_draw {
	my $plot = shift;
	my $gc = $plot->style->fg_gc ($plot->state);

	# erase (the hard way)
	$plot->{pixmap}->draw_rectangle ($plot->style->bg_gc ($plot->state),
	                                 TRUE, 0, 0,
	                                 $plot->allocation->width,
	                                 $plot->allocation->height);

	if ($plot->{max} != 0 && scalar(@{$plot->{histogram}})) {
		##GdkPoint points[256+2];
		my @hist = @{ $plot->{histogram} };
		my @points = ();
		for (my $i = 0; $i < 256; $i++) {
			push @points,
				$i/256.0 * $plot->{chartwidth} + $plot->{chartleft},
				$plot->{bottom} - $plot->{height} * $hist[$i] / $plot->{max};
		}
		$plot->{pixmap}->draw_polygon ($gc, TRUE, @points,
		              $plot->allocation->width, $plot->{bottom} + 1,
		              $plot->{chartleft}, $plot->{bottom} + 1);
	}
	# mark threshold
	# should draw this after the scale...
	draw_th_marker ($plot, $plot->{pixmap}, TRUE);
	# the annotations
	$plot->{pixmap}->draw_line ($gc, 0, 0, $plot->{chartleft}, 0);
	$plot->{pixmap}->draw_line ($gc, 0, $plot->{bottom},
				    $plot->{chartleft}, $plot->{bottom});
	$plot->{pixmap}->draw_line ($gc, $plot->{chartleft}, $plot->{bottom}, 
				    $plot->{chartleft},
				    $plot->{bottom} + $plot->{textheight} + 1);
	$plot->{pixmap}->draw_line ($gc,
		       $plot->allocation->width - 1, $plot->{bottom},
		       $plot->allocation->width - 1, $plot->{bottom} + $plot->{textheight} + 1);
	$plot->{pixmap}->draw_layout ($gc,
			 $plot->{chartleft} - (1 + $plot->{textwidth}),
			 1, $plot->{maxval_layout});
	$plot->{pixmap}->draw_layout ($gc,
			 $plot->{chartleft} - (1 + $plot->{textwidth}),
			 $plot->{bottom} - 1 - $plot->{textheight}, 
			 $plot->{origin_layout});
	$plot->{pixmap}->draw_layout ($gc,
			 $plot->{chartleft} + 2, $plot->{bottom} + 1,
			 $plot->{minscale_layout});
}

#
# change the data displayed in the window, with all the necessary
# work to get it properly updated.
#
# @threshold: new threshold.  ignored if undef.
# @histogram: new histogram.  if not empty, copy to the histwin's
#             internal histogram cache.  MUST be 256 items long.
#
sub set_plot_data {
	my ($plot, $threshold, @hist) = @_;

	$plot->{threshold} = $threshold if defined $threshold;

	if (@hist) {
		my $total = 0;
		my $max = 0;
		for (my $i = 0; $i < 256; $i++) {
			$total += $hist[$i];
			$max = $hist[$i]
				if $hist[$i] > $max;
		}
		$plot->{max} = $max;
		$plot->{histogram} = \@hist;
		$plot->{maxval_layout}->set_text 
			( sprintf "%4.1f%%", (100.0 * $plot->{max}) / $total );
	}


	# update dims since text may have changed
	$plot->calc_dims;

	# if the pixmap doesn't exist, we haven't been put on screen yet.
	# don't bother drawing anything.
	if ($plot->{pixmap}) {
		$plot->histogram_draw;
		$plot->queue_draw;
	}
}

sub do_threshold_changed {
	warn "default threshold handler";
}

################
#
# public methods
#
# we inherit new from Glib::Object::Subclass, and all the stuff we'd need
# to get to is available as object properties, so, well, there's no work
# to do here.  :-)
#


##########################################################################
# now let's take that code for a test drive...
#
package main;

use Gtk2 qw/-init -locale/;
use constant TRUE => 1;
use constant FALSE => 0;

my $window = Gtk2::Window->new;
$window->signal_connect (delete_event => sub { Gtk2->main_quit; FALSE });

my $vbox = Gtk2::VBox->new;
$window->add ($vbox);
$window->set_border_width (6);

#
# a nicely framed histogram plot with some cheesy data
#
my $plot = Histogram::Plot->new (
	threshold => 64,
	histogram => [ map { sin $_/256*3.1415 } (0..255) ]
);

my $frame = Gtk2::Frame->new;
$vbox->pack_start ($frame, TRUE, TRUE, 0);
$frame->add ($plot);
$frame->set_shadow_type ('in');

#
# a way to manipulate one of the properties...
#
my $check = Gtk2::CheckButton->new ("Continuous");
$vbox->pack_start ($check, FALSE, FALSE, 0);
$check->set_active ($plot->get ('continuous'));
$check->signal_connect (toggled => sub {
		$plot->set (continuous => $check->get_active);
		1;
		});

#
# do something fun when the threshold changes.
#
my $label = Gtk2::Label->new (sprintf "threshold: %.1f",
                                       $plot->get ('threshold'));
$vbox->pack_start ($label, FALSE, FALSE, 0);

$plot->signal_connect (threshold_changed => sub {
	$label->set_text (sprintf 'threshold: %d', $plot->get('threshold'));
	});

#
# all systems go!
#
$window->show_all;
Gtk2->main;

# explicit clean up makes us see various messages on a debug build.
undef $plot;
undef $window;