fannkuch.sd7

(********************************************************************)
(*                                                                  *)
(*  fannkuch.sd7  Fannkuch-redux benchmark program                  *)
(*  Copyright (C) 2011  Bart C                                      *)
(*                                                                  *)
(*  This program is free software; you can redistribute it and/or   *)
(*  modify it under the terms of the GNU General Public License as  *)
(*  published by the Free Software Foundation; either version 2 of  *)
(*  the License, or (at your option) any later version.             *)
(*                                                                  *)
(*  This program 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 General Public License for more details.                    *)
(*                                                                  *)
(*  You should have received a copy of the GNU General Public       *)
(*  License along with this program; if not, write to the           *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(*  For maximum performance compile this program with:              *)
(*    s7c -O2 -r fannkuch                                           *)
(*                                                                  *)
(********************************************************************)


$ include "seed7_05.s7i";
  include "stdio.s7i";

const proc: fannkuch (in integer:n, inout integer:res, inout integer:res2) is func
  local
    var integer: signx is 1;
    var integer: maxflips is 0;
    var integer: flips is 0;
    var integer: sum is 0;
    var integer: i is 0;
    var integer: j is 0;
    var integer: t is 0;
    var integer: q1 is 0;
    var integer: qq is 0;
    var integer: sx is 0;
    var boolean: finished is FALSE;
    var array integer: p is 0 times 0;
    var array integer: q is 0 times 0;
    var array integer: s is 0 times 0;
  begin

    p := n times 0;
    q := n times 0;
    s := n times 0;

    for i range 1 to n do
      p[i]:=i;
      q[i]:=i;
      s[i]:=i;
    end for;

    repeat
      q1:=p[1];

      if q1<>1 then
        for i range 2 to n do q[i]:=p[i] end for;
        flips:=1;

        qq:=q[q1];
        while qq<>1 do
          q[q1]:=q1;
          if q1>=4 then
            i:=2; j:=pred(q1);
            repeat
              t:=q[i]; q[i]:=q[j]; q[j]:=t;
              incr(i);
              decr(j);
            until i>=j
          end if;
          q1:=qq;
          incr(flips);
          qq:=q[q1];
        end while;
        sum+:=signx*flips;
        if flips>maxflips then maxflips:=flips end if;

      end if;

      if signx=1 then
        t:=p[1]; p[1]:=p[2]; p[2]:=t;
        signx:=(-1);
      else
        t:=p[2]; p[2]:=p[3]; p[3]:=t;
        signx:=1;
        for i range 3 to n do
          sx:=s[i];
          if sx<>1 then
            s[i]:=pred(sx);
            i:=succ(n);
          else
            if i=n then
              res:=sum;
              res2:=maxflips;
              finished:=TRUE;
            else
              s[i]:=i;
              t:=p[1];
              for j range 1 to i do
                p[j]:=p[succ(j)];
              end for;
              p[succ(i)]:=t;
            end if;
          end if;
        end for;
      end if;
    until finished;

  end func;


const proc: main is func
  local
    var integer: n is 0;
    var integer: sum is 0;
    var integer: flips is 0;
  begin

    n:=10;
    fannkuch(n,sum,flips);

    writeln(sum);
    writeln("Fannkuch(" <& n <& ") =" <& flips);
  end func;