#!/usr/bin/perl
print "Content-type: text/html\n\n";
### ordrlogc.cgi: PERL script to perform ORDER LOGIC.
### U. S. Government work, uncopyrighted, submitted for publication.
### See details at bottom of page.
### Last modified: 8/19/2004, G. William Moore, MD, PhD.
###
### PRINT HEADER.
print qq|<html><head><title> ORDER LOGIC CALCULATOR. </title></head><body>|;
print qq|\n<!-- Last modified: 8/19/2004, G. William Moore, MD, PhD.-->|;
print qq|\n<h2><center> ORDER LOGIC CALCULATOR. |;
print qq|\n<br><a href="http://www.netautopsy.org/ordrlogc.htm"> |;
print qq|\n http://www.netautopsy.org/ordrlogc.htm </a> |;
print qq|\n<br> U. S. Government work, uncopyrighted,|;
print qq|\n<br> submitted for publication. |;
print qq|\n<br> DRAFT COPY ONLY: DEMONSTRATION. |;
print qq|\n<br> Sample problem: the calculator should conclude |;
print qq|\n<br> that the patient is +male and -female. </center></h2> |;
###
### LOAD INPUT DATA: Microsoft(R) Excel(R) *.csv file.
### See: http://www.netautopsy.org/ordrlogc.htm
$csvar[0]="0,1,2,3,4,5,6,7,8" ; $csvar[1]="1,+i,,,,,,," ;
$csvar[2]="2,,+i,,,,,," ; $csvar[3]="3,,,+female,,,,," ;
$csvar[4]="4,,,,-male,,,," ; $csvar[5]="5,,,+male,,,,," ;
$csvar[6]="6,,,,-female,,,," ; $csvar[7]="7,,+i,,,,,," ;
$csvar[8]="8,,,+male,,,,," ;
### SAMPLE PROBLEM: THE CALCULATOR CONCLUDES THAT
### THE PATIENT IS MALE, NOT FEMALE.
### FIRST PASS THROUGH THE $csvspl ARRAY, SPLIT ON COMMAS.
$nrow=0; $irow=0; $nnomen=0; $nnam=0;
while($irow<299){$irow++; $csvlin=$csvar[$irow]; $csvlng=length($csvlin);
if($csvlng<6){$irow=1000;};
if($irow<299){$nrow++; @csvspl=split(/,/,$csvlin);
$ncsvspl=@csvspl; $icsvspl=0;
### VALUE OF SPLIT-ELEMENT=$vspl.
while($icsvspl<$ncsvspl){$icsvspl++; $vspl=$csvspl[$icsvspl];
### ROW-SIGN OF $vspl=$sgspl. LENGTH OF $vspl=$lspl.
if($vspl ne ""){$sgspl=substr($vspl,0,1); $lspl=length($vspl);
### NAME OF $vspl=$nmspl.
if($lspl>1){$nmspl=substr($vspl,1,$lspl-1); $mnam=0;
if($nmspl ne ""){$nemi=$nemon{$nmspl}-0;
### IF $nmspl ALREADY KNOWN, THEN NUMBER=$nemon{$nmspl};
if($nemi>0){$mnam=$nemi;};
### IF $nmspl NOT KNOWN, THEN INCREMENT NUMBER $nnomen.
if($nemi<1){$nnomen++; $mnam=$nnomen; $nemon{$nmspl}=$mnam;
print qq|\n<br> mnam $mnam $nmspl |;
$prprt[$nnomen]=$nmspl; $nomen[$nnomen]=$nemi;};
### ASSIGN COLUMN-NUMBER, $icsvspl, TO $rwcl[$nrow].
$rwcl[$nrow]=$icsvspl;
### ASSIGN ROW-NAME, $mnam, TO $rwnm[$nrow].
$rwnm[$nrow]=$mnam; $rwsg[$nrow]=0;
### ASSIGN ROW-SIGN, $sgspl, TO $rwsg[$nrow].
if($sgspl eq "+"){$rwsg[$nrow]=1;}
if($sgspl eq "-"){$rwsg[$nrow]=-1;};};};};};};};
$irow=0;
print qq|\n<br> Raw data matrix: $nrow rows. |;
while($irow<$nrow){$irow++; $rwln=$csvar[$irow];
print qq|\n<br> $rwln |;};
### CONSTRUCT NULLITIES/NANDSETS.
$nnand=0; $ncol=1; $irow=1;
while($irow<$nrow){$irow++;
$clnri=$rwcl[$irow]; $clnrh=$rwcl[$irow-1]+1;
### TEST FOR FIRSTBORN.
if($clnri==$clnrh){$rwsgf=$rwsg[$irow];
$rwngf=-$rwsgf; $rwnmf=$rwnm[$irow]; $rwprf=$prprt[$rwnmf];
### ZERO THE TEMPORARY NANDSET.
$krow=1; $tempn[1]=1; while($krow<$nnomen){$krow++; $tempn[$krow]=0;};
### CALCULATE PARENT TERM.
$rwsgp=$rwsg[$irow-1]; $rwngp=-$rwsgp;
$rwnmp=$rwnm[$irow-1]; $rwprp=$prprt[$rwnmp];
### COMPARE PARENT TERM TO FIRSTBORN TERM.
$jrow=$irow;
if($rwnmf==$rwnmp){
### VACUOUS NULLITY: WARNING
if($rwsgf==$rwsgp){$jrow=2*$nrow;
print qq|\n<br> Warning: vacuous nullity at row $irow: $rwnmf $rwprf |;};
### SQUAWK NULLITY: INCONSISTENCY.
if($rwngf==$rwsgp){$jrow=2*$nrow;
print qq|\n<br> SQUAWK!! Inconsistent nullity at row $irow: $rwnmf $rwprf |;
print qq|\n<br><hr> Last modified: 8/19/2004, |;
print qq| G. William Moore, MD, PhD. |;
print qq|\n <br></body></html>\n\n |; exit;};};
### IF PARENT TERM IS DISTINCT FROM FIRSTBORN TERM.
if($jrow<=$nrow){$tempn[$rwnmp]=$rwsgp; $tempn[$rwnmf]=$rwngf;
### WHILE-LOOP: TEST FOR SIBLINGS.
while($jrow<$nrow){$jrow++; $clnrj=$rwcl[$jrow];
if($clnrj==$clnri){$rwsgs=$rwsg[$jrow]; $rwngs=-$rwsgs;
$rwnms=$rwnm[$jrow]; $tempn[$rwnms]=$rwngs;};
### NO MORE SIBLINGS REMAINING: END THE WHILE-LOOP.
if($clnrj<$clnri){$jrow=2*$nrow;};};
### INCREMENT THE NANDSET MATRIX.
$nnand++; $knom=1; $nandc[$nnand]=0; $nand[$nnand][1]=0;
while($knom<$nnomen){$knom++; $tpn=$tempn[$knom];
if($tpn>0){$nandc[$nnand]++;}; if($tpn<0){$nandc[$nnand]++;};
$nand[$nnand][$knom]=$tpn;};};};};
### PRINT NANDSETS.
print "\n<br> Nandsets: ";
$knand=0;
while($knand<$nnand){$knand++; $knom=0; $tpn=$nandc[$knand];
print "\n<br> nand $knand,$tpn: ";
while($knom<$nnomen){$knom++; print " $nand[$knand][$knom]";};};
### ZERO INITIAL SOLUTIONS.
$soln[1]=-1; $knom=1; while($knom<$nnomen){$knom++; $soln[$knom]=0;};
### FIND INITIAL SOLUTIONS.
$knand=0;
while($knand<$nnand){$knand++; $tpn=$nandc[$knand];
if($tpn<2){$nandc[$knand]=0; $knom=1;
while($knom<$nnomen){$knom++; $slv=$nand[$knand][$knom];
if(($slv>0)||($slv<0)){$soln[$knom]=$slv; $hnom=0;
while($hnom<$nnomen){$hnom++; $nand[$knand][$hnom]=0;};};};};};
### PRINT INITIAL SOLUTIONS.
print "\n<br> Initial Solutions: "; $knom=0;
while($knom<$nnomen){$knom++; $slv=$soln[$knom]; $nem=$prprt[$knom];
$done[$knom]=0;
if($slv>0){print "\n<br> $knom $slv -$nem";};
if($slv<0){print "\n<br> $knom $slv +$nem";};};
### PRINT NANDSETS AGAIN.
print "\n<br> Nandsets: "; $knand=0;
while($knand<$nnand){$knand++; $knom=0; $tpn=$nandc[$knand];
print "\n<br> nand $knand,$tpn: ";
while($knom<$nnomen){$knom++; print " $nand[$knand][$knom]";};};
### ITERATIVE SOLUTION.
$isolve=0; $ksolve=0; $nsolve=$nnomen;
while($ksolve<$nsolve){$ksolve++; $done[$ksolve]=0;};
while($isolve<3){$isolve++;
### PERFORM NANDSET ARITHMETIC.
$isoln=1;
while($isoln<$nnomen){$isoln++; $slv=$soln[$isoln]; $ngslv=-$slv;
$don=$done[$isoln];
if($don<1){if(($slv>0)||($slv<0)){$knand=0;
if($slv>0){print "\n<br> isoln $isoln $slv -$prprt[$isoln]";};
if($slv<0){print "\n<br> isoln $isoln $slv +$prprt[$isoln]";};
while($knand<$nnand){$knand++; $tpn=$nandc[$knand];
if($tpn>0){$kkk=$nand[$knand][$isoln];
if(($kkk>0)||($kkk<0)){$done[$isoln]=1;
if($kkk==$slv){$nandc[$knand]=$tpn-1;
$hnom=0; $nandc[$knand]=0;
while($hnom<$nnomen){$hnom++;$nand[$knand][$hnom]=0;};};
if($kkk==$ngslv){$nandc[$knand]=$tpn-1;
$nand[$knand][$isoln]=0;};};};};};};};
### FIND NEW SOLUTIONS.
$knand=0; $istop=0;
while($knand<$nnand){$knand++; $tpn=$nandc[$knand];
if($tpn>1){$istop++;};
if($tpn<2){$nandc[$knand]=0; $knom=1;
while($knom<$nnomen){$knom++; $slv=$nand[$knand][$knom];
if(($slv>0)||($slv<0)){$soln[$knom]=$slv; $hnom=0;
if($slv>0){print "\n<br> isoln $knom $slv -$prprt[$knom]";};
if($slv<0){print "\n<br> isoln $knom $slv +$prprt[$knom]";};
while($hnom<$nnomen){$hnom++; $nand[$knand][$hnom]=0;};};};};};
### PRINT NANDSETS AGAIN.
print "\n<br> Nandsets: $isolve ";
$knand=0; $istop=0;
while($knand<$nnand){$knand++; $knom=0; $tpn=$nandc[$knand];
if($tpn>1){$istop++;};
print "\n<br> nand $knand,$tpn: ";
while($knom<$nnomen){$knom++; print " $nand[$knand][$knom]";};};
if($istop<1){$isolve=999;};};
### END JOB.
print qq|\n<br><hr> Last modified: 8/19/2004, G. William Moore, MD, PhD. |;
print qq|\n <br></body></html>\n\n |; exit;
Sub ordrlogc()
Dim nrow, irow, jrow, krow, nnam, inam, jnam, knam, hnam, knand As Integer
Dim isoln, isolve, ksolve, nsolve, ksoln, nsoln As Integer
Dim rwsav, nmsav, ndsav, rowsw, namsw, thsnam, nnand, tpk, don, slv, ngslv As Integer
Dim arr(20, 20), rwcl(20), rwsg(20), rwnm(20), tempn(20), soln(20), done(20) As Integer
Dim nandc(20), nand(20, 20) As Integer
Dim rwvij, rwvsg, rwvcl, rwvnm, namk As String
Dim rwcli, rwclj, rwclp, rwclf, rwcls As Integer
Dim rwsgi, rwsgj, rwsgp, rwsgf, rwsgs As Integer
Dim rwngi, rwngj, rwngp, rwngf, rwngs As Integer
Dim rwnmi, rwnmj, rwnmp, rwnmf, rwnms As Integer
Dim prprt(20), rwpri, rwprj, rwprp, rwprf, rwprs, prk As String
irow = 0
nrow = 0
krow = 0
rwsav = 0
nmsav = 0
ndsav = 0
rowsw = 0
nnand = 0
'Enter disease-folio from Excel Spreadsheet, by rows.
Do
irow = irow + 1
rowsw = 0
If (irow > 10) Then Exit Do
jrow = 0
'Examine the row for the unique, filled-in cell.
Do
jrow = jrow + 1
If (jrow > 10) Then Exit Do
rwvij = Cells(irow, jrow).Value
lrwvij = Len(rwvij)
If (lrwvij > 1) Then
rowsw = 1
'Row-column, rwcl(irow)
rwcl(irow) = jrow
'Row-sign, rwsg(irow)
rwvsg = Mid(rwvij, 1, 1)
If (rwvsg = "+") Then rwsg(irow) = 1
If (rwvsg = "-") Then rwsg(irow) = -1
rwvnm = Mid(rwvij, 2, lrwvij)
knam = 0
thsnam = 0
'Look for existing row-name.
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
namk = prprt(knam)
If (namk = rwvnm) Then
thsnam = knam
rwnm(irow) = knam
End If
Loop
'Increment the name-counter, nmsav.
If (thsnam = 0) Then
nmsav = nmsav + 1
prprt(nmsav) = rwvnm
thsnam = nmsav
rwnm(irow) = thsnam
End If
End If
Loop
If (rowsw > 0) Then nrow = nrow + 1
Cells(12, 2) = "name"
Cells(12, 3) = "sign"
Cells(12, 4) = "col"
Cells(irow + 12, 2) = rwnm(irow)
Cells(irow + 12, 3) = rwsg(irow)
Cells(irow + 12, 4) = rwcl(irow)
Loop
'CONSTRUCT NULLITIES/NANDSETS.
nnand = 0
ncol = 1
irow = 1
Do
irow = irow + 1
If (irow > nrow) Then Exit Do
'Test for firstborn status.
rwcli = rwcl(irow) - 1
rwclh = rwcl(irow - 1)
'Row irow is firstborn.
jrow = irow
If (rwcli = rwclh) Then
rwsgf = rwsg(irow)
rwngf = -rwsgf
rwnmf = rwnm(irow)
rwclf = rwcl(irow)
rwprf = prprt(rwnmf)
'Zero the temporary nandset.
krow = 1
tempn(1) = 1
Do
krow = krow + 1
If (krow > nmsav) Then Exit Do
tempn(krow) = 0
Loop
'Calculate the parent term.
rwsgp = rwsg(irow - 1)
rwngp = -rwsgp
rwnmp = rwnm(irow - 1)
rwclp = rwcl(irow - 1)
rwprp = prprt(rwnmp)
Cells(12, 7) = "name"
Cells(12, 8) = "sign"
Cells(12, 9) = "col"
Cells(12, 10) = "name"
Cells(12, 11) = "sign"
Cells(12, 12) = "col"
Cells(irow + 12, 7) = rwnmp
Cells(irow + 12, 8) = rwsgp
Cells(irow + 12, 9) = rwclp
Cells(irow + 12, 10) = rwnmf
Cells(irow + 12, 11) = rwsgf
Cells(irow + 12, 12) = rwclf
If (rwnmf = rwnmp) Then
'Vacuous nullity warning.
If (rwsgf = rwsgp) Then
Cells(22, 1) = "Warning: Vacuous nandset at " + prprt(rwnmp)
jrow = 2 * nrow
End If
'Inconsistent nullity warning.
If (rwngf = rwsgp) Then
Cells(22, 1) = "Warning: inconsisent nandset at " + prprt(rwnmp)
jrow = 2 * nrow
End If
End If
'If parent term distinct from firstborn term.
If (jrow <= nrow) Then
tempn(rwnmp) = rwsgp
tempn(rwnmf) = rwngf
Do
jrow = jrow + 1
If (jrow > nrow) Then Exit Do
rwclj = rwcl(jrow)
rwsgj = rwsg(jrow)
rwngj = -rwsgj
rwnmj = rwnm(jrow)
'Test for siblings.
If (rwclj = rwclf) Then
rwcls = rwclj
rwsgs = rwsgj
rwngs = -rwsgs
rwnms = rwnmj
tempn(rwnms) = rwngs
End If
'No more siblings left
If (rwclj < rwclf) Then
jrow = 2 * nrow
End If
Loop
End If
'Increment the nandset matrix.
nnand = nnand + 1
knam = 1
nandc(nnand) = 0
nand(nnand, 1) = 0
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
tpk = tempn(knam)
nand(nnand, knam) = tpk
If (tpk > 0) Then
nandc(nnand) = nandc(nnand) + 1
End If
If (tpk < 0) Then
nandc(nnand) = nandc(nnand) + 1
End If
Loop
End If
Loop
'Print nandsets.
knand = 0
Do
knand = knand + 1
If (knand > nnand) Then Exit Do
knam = 1
tpk = nandc(knand)
Cells(knand + 24, 1) = tpk
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
Cells(knand + 24, knam) = nand(knand, knam)
Loop
Loop
'Zero initial solutions.
soln(1) = -1
knam = 1
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
soln(knam) = 0
Loop
' Find initial solutions.
knand = 0
Do
knand = knand + 1
If (knand > nnand) Then Exit Do
tpk = nandc(knand)
If (tpk < 2) Then
nandc(knand) = 0
knam = 1
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
slv = nand(knand, knam)
If (slv > 0) Then
soln(knam) = slv
hnam = 0
Do
hnam = hnam + 1
If (hnam > nmsav) Then Exit Do
nand(knand, hnam) = 0
Loop
End If
If (slv < 0) Then
soln(knam) = slv
hnam = 0
Do
hnam = hnam + 1
If (hnam > nmsav) Then Exit Do
nand(knand, hnam) = 0
Loop
End If
Loop
End If
Loop
' Print initial solutions.
knam = 0
knand = 0
Do
knand = knand + 1
If (knand > nnand) Then Exit Do
knam = 0
Do
knam = knam + 1
If (knam > nmsav) Then Exit Do
slv = soln(knam)
If (slv > 0) Then
Cells(34 + knam, 1) = knam
Cells(34 + knam, 2) = slv
End If
If (slv < 0) Then
Cells(34 + knam, 1) = knam
Cells(34 + knam, 2) = slv
End If
Loop
Loop
'Iterative solution for nandsets.
isolve = 0
ksolve = 0
nsolve = nmsav
Do
ksolve = ksolve + 1
If (ksolve > nsolve) Then Exit Do
done(ksolve) = 0
Loop
Do
isolve = isolve + 1
If (isolve > nsolve) Then Exit Do
'Perform nandset arithmetic.
isoln = 1
Do
isoln = isoln + 1
If (isoln > nsolve) Then Exit Do
slv = soln(isoln)
ngslv = -slv
don = done(isoln)
If (slv > 0) Then
End If
Loop
Loop