236 lines
18 KiB
Rexx
236 lines
18 KiB
Rexx
/*REXX program displays a truth table of variables and an expression. Infix notation */
|
|
/*─────────────── is supported with one character propositional constants; variables */
|
|
/*─────────────── (propositional constants) that are allowed: A──►Z, a──►z except u.*/
|
|
/*─────────────── All propositional constants are case insensitive (except lowercase u).*/
|
|
|
|
parse arg userText /*get optional expression from the CL. */
|
|
if userText\='' then do /*Got one? Then show user's stuff. */
|
|
call truthTable userText /*display truth table for the userText.*/
|
|
exit /*we're finished with the user's text. */
|
|
end
|
|
|
|
call truthTable "G ^ H ; XOR" /*text after ; is echoed to the output.*/
|
|
call truthTable "i | j ; OR"
|
|
call truthTable "G nxor H ; NXOR"
|
|
call truthTable "k ! t ; NOR"
|
|
call truthTable "p & q ; AND"
|
|
call truthTable "e ¡ f ; NAND"
|
|
call truthTable "S | (T ^ U)"
|
|
call truthTable "(p=>q) v (q=>r)"
|
|
call truthTable "A ^ (B ^ (C ^ D))"
|
|
exit /*quit while we're ahead, by golly. */
|
|
|
|
/* ↓↓↓ no way, Jose. ↓↓↓ */ /* [↓] shows a 32,768 line truth table*/
|
|
call truthTable "A^ (B^ (C^ (D^ (E^ (F^ (G^ (H^ (I^ (J^ (L^ (L^ (M^ (N^O) ))))))))))))"
|
|
exit /*stick a fork in it, we're all done. */
|
|
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
|
truthTable: procedure; parse arg $ ';' comm 1 $o; $o= strip($o); hdrPCs=
|
|
$= translate(strip($), '|', "v"); $u= $; upper $u
|
|
$u= translate($u, '()()()', "[]{}«»"); $$.= 0; PCs=
|
|
@abc= 'abcdefghijklmnopqrstuvwxyz'; @abcU= @abc; upper @abcU
|
|
|
|
/* ╔═════════════════════╦════════════════════════════════════════════════════════════╗
|
|
║ ║ bool(bitsA, bitsB, BF) ║
|
|
║ ╟────────────────────────────────────────────────────────────╢
|
|
║ ║ performs the boolean function BF ┌──────┬─────────┐ ║
|
|
║ ║ on the A bitstring │ BF │ common │ ║
|
|
║ ║ with the B bitstring. │ value│ name │ ║
|
|
║ ║ ├──────┼─────────┤ ║
|
|
║ ║ BF must be a one to four bit │ 0000 │boolfalse│ ║
|
|
║ ║ value (from 0000 ──► 1111), │ 0001 │ and │ ║
|
|
║ This boxed table ║ leading zeroes can be omitted. │ 0010 │ NaIMPb │ ║
|
|
║ was re─constructed ║ │ 0011 │ boolB │ ║
|
|
║ from an old IBM ║ BF may have multiple values (one │ 0100 │ NbIMPa │ ║
|
|
║ publicastion: ║ for each pair of bitstrings): │ 0101 │ boolA │ ║
|
|
║ ║ │ 0110 │ xor │ ║
|
|
║ "PL/I Language ║ ┌──────┬──────┬───────────────┐ │ 0111 │ or │ ║
|
|
║ Specifications" ║ │ Abit │ Bbit │ returns │ │ 1000 │ nor │ ║
|
|
║ ║ ├──────┼──────┼───────────────┤ │ 1001 │ nxor │ ║
|
|
║ ║ │ 0 │ 0 │ 1st bit in BF │ │ 1010 │ notB │ ║
|
|
║ ║ │ 0 │ 1 │ 2nd bit in BF │ │ 1011 │ bIMPa │ ║
|
|
║ ─── March 1969. ║ │ 1 │ 0 │ 3rd bit in BF │ │ 1100 │ notA │ ║
|
|
║ ║ │ 1 │ 1 │ 4th bit in BF │ │ 1101 │ aIMPb │ ║
|
|
║ ║ └──────┴──────┴───────────────┘ │ 1110 │ nand │ ║
|
|
║ ║ │ 1111 │booltrue │ ║
|
|
║ ║ ┌──┴──────┴─────────┤ ║
|
|
║ ║ │ A 0101 │ ║
|
|
║ ║ │ B 0011 │ ║
|
|
║ ║ └───────────────────┘ ║
|
|
╚═════════════════════╩════════════════════════════════════════════════════════════╝ */
|
|
|
|
@= 'ff'x /* [↓] ───── infix operators (0──►15) */
|
|
op.= /*Note: a single quote (') wasn't */
|
|
/* implemented for negation.*/
|
|
op.0 = 'false boolFALSE' /*unconditionally FALSE */
|
|
op.1 = '& and *' /* AND, conjunction */
|
|
op.2 = 'naimpb NaIMPb' /*not A implies B */
|
|
op.3 = 'boolb boolB' /*B (value of) */
|
|
op.4 = 'nbimpa NbIMPa' /*not B implies A */
|
|
op.5 = 'boola boolA' /*A (value of) */
|
|
op.6 = '&& xor % ^' /* XOR, exclusive OR */
|
|
op.7 = '| or + v' /* OR, disjunction */
|
|
op.8 = 'nor nor ! ↓' /* NOR, not OR, Pierce operator */
|
|
op.9 = 'xnor xnor nxor' /*NXOR, not exclusive OR, not XOR */
|
|
op.10= 'notb notB' /*not B (value of) */
|
|
op.11= 'bimpa bIMPa' /* B implies A */
|
|
op.12= 'nota notA' /*not A (value of) */
|
|
op.13= 'aimpb aIMPb' /* A implies B */
|
|
op.14= 'nand nand ¡ ↑' /*NAND, not AND, Sheffer operator */
|
|
op.15= 'true boolTRUE' /*unconditionally TRUE */
|
|
/*alphabetic names that need changing. */
|
|
op.16= '\ NOT ~ ─ . ¬' /* NOT, negation */
|
|
op.17= '> GT' /*conditional */
|
|
op.18= '>= GE ─> => ──> ==>' "1a"x /*conditional; (see note below.)──┐*/
|
|
op.19= '< LT' /*conditional │*/
|
|
op.20= '<= LE <─ <= <── <==' /*conditional │*/
|
|
op.21= '\= NE ~= ─= .= ¬=' /*conditional │*/
|
|
op.22= '= EQ EQUAL EQUALS =' "1b"x /*bi─conditional; (see note below.)┐ │*/
|
|
op.23= '0 boolTRUE' /*TRUEness │ │*/
|
|
op.24= '1 boolFALSE' /*FALSEness ↓ ↓*/
|
|
/* [↑] glphys '1a'x and "1b"x can't*/
|
|
/* displayed under most DOS' & such*/
|
|
do jj=0 while op.jj\=='' | jj<16 /*change opers ──► into what REXX likes*/
|
|
new= word(op.jj, 1) /*obtain the 1st token of infex table.*/
|
|
/* [↓] process the rest of the tokens.*/
|
|
do kk=2 to words(op.jj) /*handle each of the tokens separately.*/
|
|
_=word(op.jj, kk); upper _ /*obtain another token from infix table*/
|
|
if wordpos(_, $u)==0 then iterate /*no such animal in this string. */
|
|
if datatype(new, 'm') then new!= @ /*it needs to be transcribed*/
|
|
else new!= new /*it doesn't need " " " */
|
|
$u= changestr(_, $u, new!) /*transcribe the function (maybe). */
|
|
if new!==@ then $u= changeFunc($u,@,new) /*use the internal boolean name. */
|
|
end /*kk*/
|
|
end /*jj*/
|
|
|
|
$u=translate($u, '()', "{}") /*finish cleaning up the transcribing. */
|
|
|
|
do jj=1 for length(@abcU) /*see what variables are being used. */
|
|
_= substr(@abcU, jj, 1) /*use the available upercase aLphabet. */
|
|
if pos(_,$u) == 0 then iterate /*Found one? No, then keep looking. */
|
|
$$.jj= 1 /*found: set upper bound for it. */
|
|
PCs= PCs _ /*also, add to propositional constants.*/
|
|
hdrPCs=hdrPCS center(_,length('false')) /*build a PC header for transcribing. */
|
|
end /*jj*/
|
|
|
|
ptr= '_────►_' /*a (text) pointer for the truth table.*/
|
|
$u= PCs '('$u")" /*separate the PCs from expression. */
|
|
hdrPCs= substr(hdrPCs, 2) /*create a header for the PCs. */
|
|
say hdrPCs left('', length(ptr) - 1) $o /*display PC header and expression. */
|
|
say copies('───── ', words(PCs)) left('', length(ptr) -2) copies('─', length($o))
|
|
/*Note: "true"s: are right─justified.*/
|
|
do a=0 to $$.1
|
|
do b=0 to $$.2
|
|
do c=0 to $$.3
|
|
do d=0 to $$.4
|
|
do e=0 to $$.5
|
|
do f=0 to $$.6
|
|
do g=0 to $$.7
|
|
do h=0 to $$.8
|
|
do i=0 to $$.9
|
|
do j=0 to $$.10
|
|
do k=0 to $$.11
|
|
do l=0 to $$.12
|
|
do m=0 to $$.13
|
|
do n=0 to $$.14
|
|
do o=0 to $$.15
|
|
do p=0 to $$.16
|
|
do q=0 to $$.17
|
|
do r=0 to $$.18
|
|
do s=0 to $$.19
|
|
do t=0 to $$.20
|
|
do u=0 to $$.21
|
|
do !=0 to $$.22
|
|
do w=0 to $$.23
|
|
do x=0 to $$.24
|
|
do y=0 to $$.25
|
|
do z=0 to $$.26; interpret '_=' $u
|
|
/*evaluate truth T.*/
|
|
_= changestr(1, _, '_true') /*convert 1──►_true*/
|
|
_= changestr(0, _, 'false') /*convert 0──►false*/
|
|
_= insert(ptr, _, wordindex(_, words(_) ) - 1)
|
|
say translate(_, , '_') /*display truth tab*/
|
|
end /*z*/
|
|
end /*y*/
|
|
end /*x*/
|
|
end /*w*/
|
|
end /*v*/
|
|
end /*u*/
|
|
end /*t*/
|
|
end /*s*/
|
|
end /*r*/
|
|
end /*q*/
|
|
end /*p*/
|
|
end /*o*/
|
|
end /*n*/
|
|
end /*m*/
|
|
end /*l*/
|
|
end /*k*/
|
|
end /*j*/
|
|
end /*i*/
|
|
end /*h*/
|
|
end /*g*/
|
|
end /*f*/
|
|
end /*e*/
|
|
end /*d*/
|
|
end /*c*/
|
|
end /*b*/
|
|
end /*a*/
|
|
say; say
|
|
return
|
|
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
|
scan: procedure; parse arg x,at; L= length(x); t=L; Lp=0; apost=0; quote=0
|
|
if at<0 then do; t=1; x= translate(x, '()', ")(")
|
|
end /* [↓] get 1 or 2 chars at location J*/
|
|
|
|
do j=abs(at) to t by sign(at); _=substr(x, j ,1); __=substr(x, j, 2)
|
|
if quote then do; if _\=='"' then iterate
|
|
if __=='""' then do; j= j+1; iterate; end
|
|
quote=0; iterate
|
|
end
|
|
if apost then do; if _\=="'" then iterate
|
|
if __=="''" then do; j= j+1; iterate; end
|
|
apost=0; iterate
|
|
end
|
|
if _== '"' then do; quote=1; iterate; end
|
|
if _== "'" then do; apost=1; iterate; end
|
|
if _== ' ' then iterate
|
|
if _== '(' then do; Lp= Lp+1; iterate; end
|
|
if Lp\==0 then do; if _==')' then Lp= Lp-1; iterate; end
|
|
if datatype(_, 'U') then return j - (at<0)
|
|
if at<0 then return j + 1 /*is _ uppercase ? */
|
|
end /*j*/
|
|
|
|
return min(j, L)
|
|
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
|
changeFunc: procedure; parse arg z, fC, newF ; funcPos= 0
|
|
|
|
do forever
|
|
funcPos= pos(fC, z, funcPos + 1); if funcPos==0 then return z
|
|
origPos= funcPos
|
|
z= changestr(fC, z, ",'"newF"',") /*arg 3 ≡ ",'" || newF || "-'," */
|
|
funcPos= funcPos + length(newF) + 4
|
|
where= scan(z, funcPos) ; z= insert( '}', z, where)
|
|
where= scan(z, 1 - origPos) ; z= insert('bool{', z, where)
|
|
end /*forever*/
|
|
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
|
bool: procedure; arg a,?,b /* ◄─── ARG uppercases all args.*/
|
|
|
|
select /*SELECT chooses which function.*/
|
|
/*0*/ when ? == 'FALSE' then return 0
|
|
/*1*/ when ? == 'AND' then return a & b
|
|
/*2*/ when ? == 'NAIMPB' then return \ (\a & \b)
|
|
/*3*/ when ? == 'BOOLB' then return b
|
|
/*4*/ when ? == 'NBIMPA' then return \ (\b & \a)
|
|
/*5*/ when ? == 'BOOLA' then return a
|
|
/*6*/ when ? == 'XOR' then return a && b
|
|
/*7*/ when ? == 'OR' then return a | b
|
|
/*8*/ when ? == 'NOR' then return \ (a | b)
|
|
/*9*/ when ? == 'XNOR' then return \ (a && b)
|
|
/*a*/ when ? == 'NOTB' then return \ b
|
|
/*b*/ when ? == 'BIMPA' then return \ (b & \a)
|
|
/*c*/ when ? == 'NOTA' then return \ a
|
|
/*d*/ when ? == 'AIMPB' then return \ (a & \b)
|
|
/*e*/ when ? == 'NAND' then return \ (a & b)
|
|
/*f*/ when ? == 'TRUE' then return 1
|
|
otherwise return -13
|
|
end /*select*/ /* [↑] error, unknown function.*/
|