#!/afs/athena/contrib/perl/perl

# $Header: /mit/bert/project/ching/RCS/ching.pl,v 1.4 1995/11/20 10:53:30 bert Exp bert $
# This is a port of Berkeley `ching' program to PERL.
# The port was done 21apr1995 by Albert Dvornik <bert@mit.edu>.
# The original C code bears the Berkeley copyright:

## Copyright (c) 1988 The Regents of the University of California.
## All rights reserved.
##
## This code is derived from software contributed to Berkeley by
## Guy Harris.
##
## Redistribution and use in source and binary forms are permitted
## provided that: (1) source distributions retain this entire copyright
## notice and comment, and (2) distributions including binaries display
## the following acknowledgement:  ``This product includes software
## developed by the University of California, Berkeley and its contributors''
## in the documentation or other materials provided with the distribution
## and in all advertising materials mentioning features or use of this
## software. Neither the name of the University nor the names of its
## contributors may be used to endorse or promote products derived
## from this software without specific prior written permission.
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
## IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
## WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.

require 'stdio.ph';

# hint: SGI is boneheaded.
if (!defined &SEEK_SET) { eval 'sub SEEK_SET {0;}'; }

# note: these constants used to live in ching.h
$OYIN =  6;		# yin (broken) moving to yang (solid)
$YYANG = 7;		# yang (solid)
$YYIN =  8;		# yin (broken)
$OYANG = 9;		# yang (solid) moving to yin (broken)

# note: this constant used to live in pathnames.h
$PATH_HEX  = '/afs/sipb/user/bert/dev/ching/hexagrams';

$PATH_MAC  = '/afs/sipb/user/bert/dev/ching/macros';

@table = ( $OYIN, $YYANG, $YYANG, $YYIN, $YYANG, $YYIN, $YYIN, $OYANG );

##### cno - Read a question, cast a change.

##
## Hash the question by adding all the characters together.
##
sub getquest {
    local($result) = 0;

    print STDERR "Type your question now.  ",
                 "End with control-D or a dot on a line by itself.\n";
  LINE:
    while (<>) {
	last LINE if (/^\.$/ && !$eof_only);
	$result += unpack('%8C*', $_);
    }
    return $result;
}

##
## Get a set of six lines making up a change.
##
sub change {
    local($i, $string);

    for ($i = 0; $i < 6; $i++) {
	$string .= @table[4*&getrnum() + 2*&getrnum() + 1*&getrnum()];
    }
    return $string;
}

#
# Get a number (probably) more random than the original algorithm. =)
# The result is already between 0 and 1.
#
sub getrnum {
    return int(rand(2));
}


## phx - Print NROFF/TROFF source of change, given the line values.

%table = ( 777, 0,		# 1
	   887, 1,		# 4
	   878, 2,		# 6
	   788, 3,		# 7
	   888, 4,		# 8
	   778, 5,		# 5
	   787, 6,		# 3
	   877, 7  );		# 2

##
## Gives hexagram number from two component trigrams.
##
@crosstab = ( 1,  34, 5,  26, 11, 9,  14, 43,
	      25, 51, 3,  27, 24, 42, 21, 17,
	      6,  40, 29, 4,  7,  59, 64, 47,
	      33, 62, 39, 52, 15, 53, 56, 31,
	      12, 16, 8,  23, 2,  20, 35, 45,
	      44, 32, 48, 18, 46, 57, 50, 28,
	      13, 55, 63, 22, 36, 37, 30, 49,
	      10, 54, 60, 41, 19, 61, 38, 58  );

sub hexagram {
    local($hexagram);		# hexagram number
    local($hexptr);		# string of lines
    local($i);

    local(@ARGV) = ();		# paranoia is your friend. =)

    if (scalar(@_) < 1) {
	$hexptr = <>;
	chop $hexptr;
    } else {
	$hexptr = @_[0];
    }
    if ($hexptr !~ /^\d{6}$/) {
	&usage;
    }

    @trigrams = unpack("a1"x6, $hexptr);
    @moving = ();
    foreach (@trigrams) {
	push(@moving, ($_ == 6 || $_ == 9));
    }

    open(CHING, $PATH_HEX) || die "ching: can't read $PATH_HEX\n";

    &phx(&doahex(), 0);
    if (&changes()) {
	&phx(&doahex(), 1);
    }

    close(CHING);
}

##
## Compute the hexagram number, given the trigrams.
##
sub doahex {
    # encoded values of lower and upper trigrams
    local($lower,$upper) = ( &codem(0), &codem(3) );

    # indices of upper and lower trigrams
    local($lnum,$unum) = ( $table{$lower} ,$table{$upper} );

    return $crosstab[8*$lnum+$unum];
}

##
## Encode a trigram as a 3-digit number; the digits, from left to right,
## represent the lines.  7 is a solid (yang) line, 8 is a broken (yin) line.
##
sub codem {
    local($a) = @_;
    local($code,$i) = (0);

    local(@factor) = (1,10,100);

    for ($i = $a; $i < ($a + 3); $i++) {
	(($trigrams[$i] == $YYANG) ||
	 ($trigrams[$i] == $OYANG)) &&
	     do { $code += $factor[$i%3]*7; };

	(($trigrams[$i] == $OYIN) ||
	 ($trigrams[$i] == $YYIN)) &&
	     do { $code += $factor[$i%3]*8; };
    }
    return $code;
}

##
## Compute the changes based on moving lines; return number of lines moved.
##
sub changes {
    scalar(grep( (($_ == $OYIN)  && ($_ = $YYANG)) || 
		 (($_ == $OYANG) && ($_ = $YYIN)),
		  @trigrams));
}

##
## Print the NROFF/TROFF source of a hexagram, given the hexagram number;
## if flag is 0, print the entire source; if flag is 1, ignore the meanings
## of the lines.
##
sub phx {
    local($hexagram, $flag) = @_;

    local($allmoving);		## 1 if all lines are moving
    local($i);

    ## Search for the hexagram; it begins with a line of the form
    ## .H <hexagram number> <other data>.

    seek(CHING, 0, &SEEK_SET);   # this does a rewind()
    
  LEADING:
    while (<CHING>) {
	/^\.H\s+$hexagram\s/ && last LEADING;
    }

    $_ || die "ching: Hexagram $hexagram missing\n";

    ##
    ## Print up to the line commentary, which ends with a line of the form
    ## .L <position> <value>
    ##
    print TROFF;

  HEXCOMMENT:
    while (<CHING>) {
	/^\.L/ && last HEXCOMMENT;
	print TROFF;
    }

    $_ || die "ching: Hexagram $hexagram malformed\n";

    ##
    ## Now print the line commentaries, if this is the first hexagram.
    ##
    if ($flag) {
	return;
    }

    ##
    ## If a line is moving, print its commentary.
    ## The text of the commentary ends with a line either of the form
    ## .L <position> <value>
    ## or of the form
    ## .LA <value>
    ## or of the form
    ## .H <hexagram number> <other arguments>
    ##
    $allmoving = 1;
    for ($i = 0; $i < 6; $i++) {
	local($line) = i+1;
	/^\.L\s+$line\s*$/ && die "ching: Hexagram $hexagram malformed\n";

	if ($moving[$i]) {
	    print TROFF;
	} else {
	    $allmoving = 0;
	}

      LINECOMMENT:
	while (<CHING>) {
	    /^\.[HL]/ && last LINECOMMENT;
	    $moving[$i] && print TROFF;
	}
    }

    ##
    ## If all the lines are moving, print the commentary for that; it
    ## ends with a line of the form
    ## .H <hexagram number> <other arguments>
    ##
    if (/^\.LA/ && $allmoving) {
	print TROFF;
      ALLMOVING:
	while (<CHING>) {
	    /^\.H/ && last ALLMOVING;
	    print TROFF;
	}
    }
}

##### usage message

sub usage {
    die "usage:    ching [-troff] [-number] [-page prog] [hexagram-number]\n";
}

###### main body

$more = $ENV{'PAGER'} || 'more -s';
$tmpout = "/tmp/ching.$$";

@sARGV = @ARGV;

while ($ARGV[0] =~ /^-/) {
    shift(@ARGV);
    ($' eq 'troff') && ($spew_troff++, next);
    ($' eq 'number') && ($printnum++, next);
    ($' eq 'page') && ($more = shift(@ARGV) || &usage, next);
    &usage;
}

srand(time + &getquest() + $< + $( + $$) # randomize
    unless @ARGV;

if ($spew_troff) {
    open (TROFF, ">&STDOUT") || die "ching: can't open STDOUT";
} else {
    open (TROFF, ">$tmpout") || die "ching: can't open $tmpout";
}

if (@ARGV) {
    &hexagram(($chng)=@ARGV);
} else {
    &hexagram($chng=&change());
}

close(TROFF);
if (!$spew_troff) {
    system "nroff $PATH_MAC $tmpout | $more";
    unlink($tmpout);
}

if ($printnum) {
    printf STDOUT "change lines: %d\n", $chng;
    exit 0;
}
