fortune.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Gtk3 -init;
   7 use Cairo;
   8
   9 my $pi = 3.1415926536;
  10
  11 sub sqr($) {
  12         my ($x) = @_;
  13         return $x * $x;
  14 }
  15
  16 sub is_zero($) {
  17         my ($x) = @_;
  18         return ($x < 1e-10 && $x > -1e-10);
  19 }
  20
  21 sub draw_para($$$$$) {
  22         # Draw a parabola y=a(x-x0)^2 + y0
  23         my ($cairo,$a,$x0,$y0,$ww) = @_;
  24         if (!defined($a)) {
  25                 # Degenerate parabola
  26                 $cairo->move_to($x0, $y0);
  27                 $cairo->line_to($x0, 0);
  28         } else {
  29                 my $been = 0;
  30                 for (my $x=0; $x<$ww; $x++) {
  31                         my $y = $a*sqr($x-$x0) + $y0;
  32                         next if ($y < -10000 || $y > 10000);
  33                         if ($been++) {
  34                                 $cairo->line_to($x, $y);
  35                         } else {
  36                                 $cairo->move_to($x, $y);
  37                         }
  38                 }
  39         }
  40         $cairo->stroke;
  41 }
  42
  43 sub solve_para($$$) {
  44         my ($h0, $x0, $y0) = @_;
  45         my $h = $y0 - $h0;
  46         if (is_zero($h)) {
  47                 return (undef, $x0, $h0);
  48         } else {
  49                 return (1/(2*$h), $x0, $h0 + $h/2);
  50         }
  51 }
  52
  53 sub solve_circ($$$$$$) {
  54         my ($x0, $y0, $x1, $y1, $x2, $y2) = @_;
  55         my $axc = ($x0 + $x1) / 2;
  56         my $ayc = ($y0 + $y1) / 2;
  57         my $adx = $y1 - $y0;
  58         my $ady = $x0 - $x1;
  59         my $bxc = ($x1 + $x2) / 2;
  60         my $byc = ($y1 + $y2) / 2;
  61         my $bdx = $y2 - $y1;
  62         my $bdy = $x1 - $x2;
  63         my $alpha = (($bxc-$axc)*(-$bdy) - ($byc-$ayc)*(-$bdx)) /
  64                     ($adx*(-$bdy) - $ady*(-$bdx));
  65         my $x = $axc + $alpha*$adx;
  66         my $y = $ayc + $alpha*$ady;
  67         my $r = sqrt(sqr($x-$x0) + sqr($y-$y0));
  68         return ($x, $y, $r);
  69 }
  70
  71 sub para_isec($$$$$$) {
  72         # Parameters of two parabolas
  73         my ($a, $b, $c, $d, $e, $f) = @_;
  74         if (!defined($a) || !defined($b)) {
  75                 # Either is degenerate
  76                 if (defined($a)) {
  77                         my $y = $a*sqr($e-$b) + $c;
  78                         if ($y < $f) { return [$e, $y]; } else { return; }
  79                 } elsif (defined($d)) {
  80                         my $y = $d*sqr($b-$e) + $f;
  81                         if ($y < $c) { return [$b, $y]; } else { return; }
  82                 }
  83                 return;
  84         }
  85         # Coefficients of the corresponding quadratic equation
  86         my $A = $a - $d;
  87         my $B = 2*($d*$e - $a*$b);
  88         my $C = $a*sqr($b) - $d*sqr($e) + $c - $f;
  89         # Is the equation linear?
  90         if (is_zero($A)) {
  91                 if (is_zero($B)) { return; }
  92                 my $x = -$C/$B;
  93                 my $y = $a*sqr($x-$b) + $c;
  94                 return [$x, $y];
  95         }
  96         # No, really quadratic. Consider its discriminant.
  97         my $D = sqr($B) - 4*$A*$C;
  98         if ($D < 0) {
  99                 return;
 100         } elsif (is_zero($D)) {
 101                 my $x = -$B / (2*$A);
 102                 my $y = $a*sqr($x-$b) + $c;
 103                 return [$x, $y];
 104         } else {
 105                 my $DD = sqrt($D);
 106                 my $x1 = (-$B + $DD) / (2*$A);
 107                 my $x2 = (-$B - $DD) / (2*$A);
 108                 if ($x1 > $x2) { ($x1,$x2) = ($x2,$x1); }
 109                 my $y1 = $a*sqr($x1-$b) + $c;
 110                 my $y2 = $a*sqr($x2-$b) + $c;
 111                 return ([$x1,$y1], [$x2,$y2]);  # In order left, right
 112         }
 113 }
 114
 115 my $area = Gtk3::DrawingArea->new();
 116 my $dh = 620;
 117 sub draw {
 118         my ($cairo) = @_;
 119         my $w = $area->get_allocated_width;
 120         my $h = $area->get_allocated_height;
 121
 122         $cairo->rectangle(0, 0, $w, $h);
 123         $cairo->set_source_rgb(0, 0, 0);
 124         $cairo->fill;
 125
 126         my @pts = ( [$w/3, $h-600], [$w/2, $h-700], [2*$w/3, $h-650] );
 127         my ($cx, $cy, $cr) = solve_circ($pts[0]->[0], $pts[0]->[1], $pts[1]->[0], $pts[1]->[1], $pts[2]->[0], $pts[2]->[1]);
 128         my $ch = $cy + $cr;
 129         my $h0 = $h-$dh;
 130         if (abs($ch-$h0) < 2) {
 131                 $h0 = $ch;
 132         }
 133
 134         for (my $i=0; $i<$#pts; $i++) {
 135                 my $p = $pts[$i];
 136                 my $q = $pts[$i+1];
 137                 my $xc = ($p->[0] + $q->[0]) / 2;
 138                 my $yc = ($p->[1] + $q->[1]) / 2;
 139                 my $dx = ($q->[1] - $p->[1]);
 140                 my $dy = ($p->[0] - $q->[0]);
 141                 $cairo->set_source_rgb(0.5, 0, 0.5);
 142                 $cairo->move_to($xc - 10*$dx, $yc - 10*$dy);
 143                 $cairo->line_to($xc + 10*$dx, $yc + 10*$dy);
 144                 $cairo->stroke;
 145                 $cairo->set_source_rgb(0.5, 0.5, 0.5);
 146                 $cairo->move_to($p->[0], $p->[1]);
 147                 $cairo->line_to($q->[0], $q->[1]);
 148                 $cairo->stroke;
 149         }
 150         {
 151                 my $p = $pts[0];
 152                 my $q = $pts[2];
 153                 my $xc = ($p->[0] + $q->[0]) / 2;
 154                 my $yc = ($p->[1] + $q->[1]) / 2;
 155                 my $dx = ($q->[1] - $p->[1]);
 156                 my $dy = ($p->[0] - $q->[0]);
 157                 $cairo->set_source_rgb(0.5, 0, 0.5);
 158                 $cairo->move_to($xc - 10*$dx, $yc - 10*$dy);
 159                 $cairo->line_to($xc + 10*$dx, $yc + 10*$dy);
 160                 $cairo->stroke;
 161                 $cairo->set_source_rgb(0.5, 0.5, 0.5);
 162                 $cairo->move_to($p->[0], $p->[1]);
 163                 $cairo->line_to($q->[0], $q->[1]);
 164                 $cairo->stroke;
 165         }
 166
 167         $cairo->set_source_rgb(1, 0, 1);
 168         $cairo->arc($cx, $cy, $cr, 0, 2*$pi);
 169         $cairo->stroke;
 170
 171         $cairo->set_source_rgb(1, 1, 1);
 172         $cairo->move_to(0, $h0);
 173         $cairo->line_to($w, $h0);
 174         $cairo->stroke;
 175
 176         foreach my $p (@pts) {
 177                 $cairo->arc($p->[0], $p->[1], 2, 0, 2*$pi);
 178                 $cairo->fill;
 179         }
 180
 181         $cairo->set_source_rgb(0, 1, 0);
 182         my @paras = ();
 183         foreach my $p (@pts) {
 184                 next if ($p->[1] > $h0);
 185                 my ($pa,$px,$py) = solve_para($h0, $p->[0], $p->[1]);
 186                 draw_para($cairo, $pa, $px, $py, $w);
 187                 push @paras, [$pa,$px,$py];
 188         }
 189         if ($h0 > $ch) {
 190                 splice @paras, 1, 1;
 191         }
 192         for (my $i=0; $i<$#paras; $i++) {
 193                 my $p = $paras[$i];
 194                 my $q = $paras[$i+1];
 195                 my @isec = para_isec($p->[0], $p->[1], $p->[2], $q->[0], $q->[1], $q->[2]);
 196                 foreach my $pt (@isec) {
 197                         $cairo->set_source_rgb(1, 0, 0);
 198                         $cairo->arc($pt->[0], $pt->[1], 2, 0, 2*$pi);
 199                         $cairo->fill;
 200                 }
 201         }
 202 }
 203
 204 my $timer;
 205 $area->signal_connect("draw" => sub {
 206         my ($w, $cr) = @_;
 207         draw($cr);
 208 });
 209
 210 my $window = Gtk3::Window->new ('toplevel');
 211 $window->signal_connect ("delete-event" => sub { Gtk3->main_quit });
 212 $window->set_title("Brum");
 213 $window->set_wmclass("anim", "Anim");
 214 $window->set_default_size(640, 480);
 215 $window->add ($area);
 216 $window->show_all;
 217 $window->fullscreen;
 218 $window->signal_connect("key-press-event" => sub {
 219         my ($w, $evt) = @_;
 220         my $k = Gtk3::Gdk::keyval_name($evt->keyval);
 221         if ($k eq "space" || $k eq "Right" || $k eq "Return") {
 222                 $dh -= 10;
 223                 $area->queue_draw();
 224         } elsif ($k eq "q" || $k eq "Escape") {
 225                 Gtk3->main_quit;
 226         }
 227 });
 228
 229 Gtk3->main;