annotate fft/fftw/fftw-3.3.4/doc/FAQ/bfnnconv.pl @ 40:223f770b5341 kissfft-double tip

Try a double-precision kissfft

#!/usr/bin/perl --
# Copyright (C) 1993-1995 Ian Jackson.

# This file 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, or (at your option)
# any later version.

# It 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 GNU Emacs; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.

# (Note: I do not consider works produced using these BFNN processing
# tools to be derivative works of the tools, so they are NOT covered
# by the GPL.  However, I would appreciate it if you credited me if
# appropriate in any documents you format using BFNN.)

@outputs=('ascii','info','html');

while ($ARGV[0] =~ m/^\-/) {
    $_= shift(@ARGV);
    if (m/^-only/) {
        @outputs= (shift(@ARGV));
    } else {
        warn "unknown option `$_' ignored";
    }
}

$prefix= $ARGV[0];
$prefix= 'stdin' unless length($prefix);
$prefix =~ s/\.bfnn$//;

if (open(O,"$prefix.xrefdb")) {
    @xrefdb= <O>;
    close(O);
} else {
    warn "no $prefix.xrefdb ($!)";
}

$section= -1;
for $thisxr (@xrefdb) {
    $_= $thisxr;
    chop;
    if (m/^Q (\w+) ((\d+)\.(\d+)) (.*)$/) {
        $qrefn{$1}= $2;
        $qreft{$1}= $5;
        $qn2ref{$3,$4}= $1;
        $maxsection= $3;
        $maxquestion[$3]= $4;
    } elsif (m/^S (\d+) /) {
        $maxsection= $1;
        $sn2title{$1}=$';
    }
}

open(U,">$prefix.xrefdb-new");

for $x (@outputs) { require("m-$x.pl"); }

&call('init');

while (<>) {
    chop;
    next if m/^\\comment\b/;
    if (!m/\S/) {
        &call('endpara');
        next;
    }
    if (s/^\\section +//) {
        $line= $_;
        $section++; $question=0;
        print U "S $section $line\n";
        $|=1; print "S$section",' 'x10,"\r"; $|=0;
        &call('endpara');
        &call('startmajorheading',"$section",
              "Section $section",
              $section<$maxsection ? "Section ".($section+1) : '',
              $section>1 ? 'Section '.($section-1) : 'Top');
        &text($line);
        &call('endmajorheading');
        if ($section) {
            &call('endpara');
            &call('startindex');
            for $thisxr (@xrefdb) {
                $_= $thisxr;
                chop;
                if (m/^Q (\w+) (\d+)\.(\d+) (.*)$/) {
                    $ref= $1; $num1= $2; $num2= $3; $text= $4;
                    next unless $num1 == $section;
                    &call('startindexitem',$ref,"Q$num1.$num2","Question $num1.$num2");
                    &text($text);
                    &call('endindexitem');
                }
            }
            &call('endindex');
        }
    } elsif (s/^\\question \d{2}[a-z]{3}((:\w+)?) +//) {
        $line= $_;
        $question++;
        $qrefstring= $1;
        $qrefstring= "q_${section}_$question" unless $qrefstring =~ s/^://;
        print U "Q $qrefstring $section.$question $line\n";
        $|=1; print "Q$section.$question",' 'x10,"\r"; $|=0;
        &call('endpara');
        &call('startminorheading',$qrefstring,
              "Question $section.$question",
              $question < $maxquestion[$section] ? "Question $section.".($question+1) :
              $section < $maxsection ? "Question ".($section+1).".1" : '',
              $question > 1 ? "Question $section.".($question-1) :
              $section > 1 ? "Question ".($section-1).'.'.($maxquestion[$section-1]) :
              'Top',
              "Section $section");
        &text("Question $section.$question.  $line");
        &call('endminorheading');
    } elsif (s/^\\only +//) {
        @saveoutputs= @outputs;
        @outputs=();
        for $x (split(/\s+/,$_)) {
            push(@outputs,$x) if grep($x eq $_, @saveoutputs);
        }
    } elsif (s/^\\endonly$//) {
        @outputs= @saveoutputs;
    } elsif (s/^\\copyto +//) {
        $fh= $';
        while(<>) {
            last if m/^\\endcopy$/;
            while (s/^([^\`]*)\`//) {
                print $fh $1;
                m/([^\\])\`/ || warn "`$_'";
                $_= $';
                $cmd= $`.$1;
                $it= `$cmd`; chop $it;
                print $fh $it;
            }
            print $fh $_;
        }
    } elsif (m/\\index$/) {
        &call('startindex');
        for $thisxr (@xrefdb) {
            $_= $thisxr;
            chop;
            if (m/^Q (\w+) (\d+\.\d+) (.*)$/) {
                $ref= $1; $num= $2; $text= $3;
                &call('startindexitem',$ref,"Q$num","Question $num");
                &text($text);
                &call('endindexitem');
            } elsif (m/^S (\d+) (.*)$/) {
                $num= $1; $text= $2;
                next unless $num;
                &call('startindexmainitem',"s_$num",
                      "Section $num.","Section $num");
                &text($text);
                &call('endindexitem');
            } else {
                warn $_;
            }
        }
        &call('endindex');
    } elsif (m/^\\call-(\w+) +(\w+)\s*(.*)$/) {
        $fn= $1.'_'.$2;
        eval { &$fn($3); };
        warn $@ if length($@);
    } elsif (m/^\\call +(\w+)\s*(.*)$/) {
        eval { &call($1,$2); };
        warn $@ if length($@);
    } elsif (s/^\\set +(\w+)\s*//) {
        $svalue= $'; $svari= $1;
        eval("\$user_$svari=\$svalue"); $@ && warn "setting $svalue failed: $@\n";
    } elsif (m/^\\verbatim$/) {
        &call('startverbatim');
        while (<>) {
            chop;
            last if m/^\\endverbatim$/;
            &call('verbatim',$_);
        }
        &call('endverbatim');
    } else {
        s/\.$/\. /;
        &text($_." ");
    }
}

print ' 'x25,"\r";
&call('finish');
rename("$prefix.xrefdb-new","$prefix.xrefdb") || warn "rename xrefdb: $!";
exit 0;


sub text {
    local($in,$rhs,$word,$refn,$reft,$fn,$style);
    $in= "$holdover$_[0]";
    $holdover= '';
    while ($in =~ m/\\/) {
#print STDERR ">$`##$'\n";
        $rhs=$';
        &call('text',$`);
        $_= $rhs;
        if (m/^\w+ $/) {
            $holdover= "\\$&";
            $in= '';
        } elsif (s/^fn\s+([^\s\\]*\w)//) {
            $in= $_;
            $word= $1;
            &call('courier');
            &call('text',$word);
            &call('endcourier');
        } elsif (s/^tab\s+(\d+)\s+//) {
            $in= $_; &call('tab',$1);
        } elsif (s/^nl\s+//) {
            $in= $_; &call('newline');
        } elsif (s/^qref\s+(\w+)//) {
            $refn= $qrefn{$1};
            $reft= $qreft{$1};
            if (!length($refn)) {
                warn "unknown question `$1'";
            }
            $in= "$`\\pageref:$1:$refn:$reft\\endpageref.$_";
        } elsif (s/^pageref:(\w+):([^:\n]+)://) {
            $in= $_;
            &call('pageref',$1,$2);
        } elsif (s/^endpageref\.//) {
            $in= $_; &call('endpageref');
        } elsif (s/^(\w+)\{//) {
            $in= $_; $fn= $1;
            eval { &call("$fn"); };
            if (length($@)) { warn $@; $fn= 'x'; }
            push(@styles,$fn);
        } elsif (s/^\}//) {
            $in= $_;
            $fn= pop(@styles);
            if ($fn ne 'x') { &call("end$fn"); }
        } elsif (s/^\\//) {
            $in= $_;
            &call('text',"\\");
        } elsif (s,^(\w+)\s+([-A-Za-z0-9.\@:/]*\w),,) {
#print STDERR "**$&**$_\n";
            $in= $_;
            $style=$1; $word= $2;
            &call($style);
            &call('text',$word);
            &call("end$style");
        } else {
            warn "unknown control `\\$_'";
            $in= $_;
        }
    }
    &call('text',$in);
}


sub call {
    local ($fnbase, @callargs) = @_;
    local ($coutput);
    for $coutput (@outputs) {
        if ($fnbase eq 'text' && eval("\@${coutput}_cmds")) {
#print STDERR "special handling text (@callargs) for $coutput\n";
            $evstrg= "\$${coutput}_args[\$#${coutput}_args].=\"\@callargs\"";
            eval($evstrg);
            length($@) && warn "call adding for $coutput (($evstrg)): $@";
        } else {
            $fntc= $coutput.'_'.$fnbase; 
            &$fntc(@callargs);
        }
    }
}


sub recurse {
    local (@outputs) = $coutput;
    local ($holdover);
    &text($_[0]);
}


sub arg {
#print STDERR "arg($_[0]) from $coutput\n";
    $cmd= $_[0];
    eval("push(\@${coutput}_cmds,\$cmd); push(\@${coutput}_args,'')");
    length($@) && warn "arg setting up for $coutput: $@";
}

sub endarg {
#print STDERR "endarg($_[0]) from $coutput\n";
    $evstrg= "\$${coutput}_cmd= \$cmd= pop(\@${coutput}_cmds); ".
             "\$${coutput}_arg= \$arg= pop(\@${coutput}_args); ";
    eval($evstrg);
    length($@) && warn "endarg extracting for $coutput (($evstrg)): $@";
#print STDERR ">call $coutput $cmd $arg< (($evstrg))\n";
    $evstrg= "&${coutput}_do_${cmd}(\$arg)";
    eval($evstrg);
    length($@) && warn "endarg running ${coutput}_do_${cmd} (($evstrg)): $@";
}