Rosetta Code

Truth table: Difference between revisions

Page Discussion

Truth table (view source)

Revision as of 04:10, 13 August 2018

4,575 bytes added ,  5 years ago
→‎{{header|REXX}}: added/changed comments and whitespace, changed some variable names.
(→‎{{header|REXX}}: added/changed comments and whitespace, changed some variable names.)
Line 2,685:
<br>through the 26 possible propositional constants (which makes a deeply nested DO construct, if nothing else, it looks pretty).
<br>I later added support for all 16 boolean functions --- REXX natively supports three infix operators:
::* &nbsp; '''&''' &nbsp; &nbsp; (and)
::* &nbsp; '''|''' &nbsp; &nbsp; &nbsp; (or)
::* &nbsp; '''&&''' &nbsp; &nbsp; (xor)
and one prefix operator:
::* &nbsp; '''¬''' &nbsp; &nbsp; (not or negation).
Some REXX intepretersinterpreters also (or instead) support:
::* &nbsp; '''\''' &nbsp; &nbsp; (backslash)
::* &nbsp; '''/''' &nbsp; &nbsp; (forward slash)
::* &nbsp; '''~''' &nbsp; &nbsp; (tidletilde)
::* &nbsp; '''^''' &nbsp; &nbsp; (carotcaret)
Also included is support for two boolean values: '''TRUE''' and '''FALSE''' which are part of boolean expressions.
<lang rexx>♀/*REXX program displays a truth table theof variables and an expression. Infix notation */
/*Infix notation─────────────── is supported with one character propositional constants; variables */
/*variables─────────────── (propositional constants) that are allowed: A──►Z, a──►z except u. */
/*─────────────── All propositional constants are case insensativeinsensitive (except lowercase vu).*/
 
parse arg expressionuserText /*get optional expression from the CCL.L. */
if expressionuserText\='' then do /*Got one? Then show user's stuff. */
call truthTable expressionuserText /*showdisplay truth table andfor tellthe T.TuserText.*/
exit exit /*we're all donefinished with truththe user's text. table*/
end
 
call truthTable "G ^ H ; XOR" /*txttext after ; is shownechoed to inthe 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 gumgolly. */
 
/* ↓↓↓ no way, Jose. ↓↓↓ */ /* [↓] shows a 32,768 line truth table*/
call truthTable "A^ (B^ (C^ (D^ (E^ (F^ (G^ (H^ (I^ (J^ (L^ (NL^ (NM^ (ON^PO) ))))))))))))"
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
 
/* ╔═════════════════════╦════════════════════════════════════════════════════════════╗
/*─────────────────────────────────────truthTable subroutine────────────*/
║ ║ bool(bitsA, bitsB, BF) ║
truthTable: procedure; parse arg $ ';' comm 1 $o; $o=strip($o)
║ ╟────────────────────────────────────────────────────────────╢
$=translate(strip($),'|',"v"); $u=$; upper $u
║ ║ performs the boolean function BF ┌──────┬─────────┐ ║
$u=translate($u,'()()()',"[]{}«»"); $$.=0; PCs=; hdrPCs=
║ ║ on the A bitstring │ BF │ common │ ║
@abc='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU
║ ║ 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) */
/* The boxed table below was constructed from an old IBM publication:
op.= /*Note: a single quote (') wasn't */
"PL/I Language Specifications" ─── March 1968.
/* 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. */
┌────────────────────────────────────────────────────────────┐
│ 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 │ │
│ leading zeroes can be omitted. │ 0010 │ NaIMPb │ │
│ │ 0011 │ boolB │ │
│ BF may have multiple values (one │ 0100 │ NbIMPa │ │
│ for each pair of bitstrings): │ 0101 │ boolA │ │
│ │ 0110 │ xor │ │
│ ┌──────┬──────┬───────────────┐ │ 0111 │ or │ │
│ │ Abit │ Bbit │ returns │ │ 1000 │ nor │ │
│ ├──────┼──────┼───────────────┤ │ 1001 │ nxor │ │
│ │ 0 │ 0 │ 1st bit in BF │ │ 1010 │ notB │ │
│ │ 0 │ 1 │ 2nd bit in BF │ │ 1011 │ bIMPa │ │
│ │ 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 do jj=1 for length(@abcU) /*see what variables are being used. /*─────────infix operators───────*/
op.= _= substr(@abcU, jj, 1) /*a single quote (') wasn't use the available upercase aLphabet. */
if pos(_,$u) == 0 then iterate /*Found one? No, implementedthen forkeep negationlooking. */
op.0 $$.jj='false 1 boolFALSE' /*unconditionallyfound: FALSEset upper bound for it. */
op.1 ='& and *' PCs= PCs _ /* AND, conjunction /*also, add to propositional constants.*/
hdrPCs=hdrPCS center(_,length('false')) /*build a PC header for transcribing. */
op.2 ='naimpb NaIMPb' /*not A implies B */
end /*jj*/
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 need changing.*/
op.16='\ NOT ~ ─ . ¬' /* NOT, negation */
op.17='> GT' /*conditional */
op.18='>= GE ─> => ──> ==>' "1a"x /*conditional */
op.19='< LT' /*conditional */
op.20='<= LE <─ <= <── <==' /*conditional */
op.21='\= NE ~= ─= .= ¬=' /*conditional */
op.22='= EQ EQUAL EQUALS =' "1b"x /*biconditional */
op.23='0 boolTRUE' /*TRUEness */
op.24='1 boolFALSE' /*FALSEness */
 
ptr= '_────►_' /*a (text) pointer for the truth table.*/
do jj=0 while op.jj\=='' | jj<16 /*change opers──►what REXX likes.*/
$u= PCs '('$u")" /*separate the PCs from expression. */
new=word(op.jj,1)
hdrPCs= substr(hdrPCs, do kk=2) to words(op.jj) /*handlecreate eacha tokenheader separatelyfor the PCs. */
say hdrPCs left('', length(ptr) - 1) $o /*display PC header and expression. */
_=word(op.jj,kk); upper _
say copies('───── ', words(PCs)) left('', length(ptr) -2) copies('─', length($o))
if wordpos(_,$u)==0 then iterate /*no such animal in this string. */
/*Note: "true"s: are right─justified.*/
if datatype(new,'m') then new!=? /*expresion needs transcribing. */
do a=0 to else new!=new$$.1
$u=changestr(_,$u,new!) /*transcribe thedo functionb=0 (maybe)*/ to $$.2
do c=0 to $$.3
if new!==? then $u=changeFunc($u,?,new) /*use internal bool name.*/
do d=0 to $$.4
end /*kk*/
do e=0 to $$.5
end /*jj*/
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)
$u=translate($u, '()', "{}") /*finish cleaning up transcribing*/
do jj=1 for length(@abcU) if quote /*see what variables are used. */ then do; if _\=='"' then iterate
if __=='""' then do; j= j+1; iterate; end
_=substr(@abcU,jj,1) /*use available upercase alphabet*/
quote=0; iterate
if pos(_,$u)==0 then iterate /*found one? No, keep looking. */
$$.jj=1 /*found: set upper bound for it.*/end
PCs=PCs _ if apost then do; if _\=="'" /*also, add to propositionalthen cons*/iterate
if __=="''" then do; j= j+1; iterate; end
hdrPCs=hdrPCS center(_,length('false')) /*build a PC header.*/
apost=0; iterate
end /*jj*/
$u=PCs '('$u")" /*separate PCs from expression. */ end
ptr='_────►_' if _== '"' then /*ado; pointer forquote=1; the truthiterate; table. */end
hdrPCs=substr(hdrPCs,2) if _== "'" /*create a header for the PCs. */ then do; apost=1; iterate; end
if _== ' ' then iterate
say hdrPCs left('',length(ptr)-1) $o /*display PC header + expression.*/
if _== '(' then do; Lp= Lp+1; iterate; end
say copies('───── ',words(PCs)) left('',length(ptr)-2) copies('─',length($o))
if Lp\==0 then do; if _==')' then Lp= Lp-1; /*Note: "true"s: iterate; right─justified*/ end
if datatype(_, 'U') then return j - (at<0)
do a=0 to $$.1
if at<0 then return j + 1 /*is _ uppercase ? */
do b=0 to $$.2
do c=0 to $$.3 end /*j*/
 
do d=0 to $$.4
do e=0return min(j, to $$.5L)
/*──────────────────────────────────────────────────────────────────────────────────────*/
do f=0 to $$.6
changeFunc: procedure; parse arg z, fC, newF ; funcPos= 0
do g=0 to $$.7
 
do h=0 to $$.8
do i=0 to $$.9 do forever
funcPos= pos(fC, z, funcPos + 1); if funcPos==0 then return z
do j=0 to $$.10
do k=0 toorigPos= $$.11funcPos
z= changestr(fC, z, ",'"newF"',") /*arg 3 ≡ ",'" || newF || "-'," */
do l=0 to $$.12
do mfuncPos=0 funcPos to+ $$.13length(newF) + 4
do n where=0 scan(z, funcPos) ; z= insert( '}', z, to $$.14where)
do owhere=0 scan(z, to1 $$.15- origPos) ; z= insert('bool{', z, where)
end do p=0 to $$.16/*forever*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
do q=0 to $$.17
bool: procedure; arg a,?,b do r=0 to $$ /* ◄─── ARG uppercases all args.18*/
 
do s=0 to $$.19
do t=0 to $$ select /*SELECT chooses which function.20*/
/*0*/ dowhen ? u=0= 'FALSE' to $$.21 then return 0
/*1*/ when do? !=0= 'AND' then return a to& $$.22b
/*2*/ when ? do w=0= 'NAIMPB' then return \ (\a to& $$.23\b)
/*3*/ when ? == do'BOOLB' x=0 tothen return $$.24b
/*4*/ when ? == 'NBIMPA' do y=0then return \ (\b to& $$.25\a)
/*5*/ when ? == 'BOOLA' do z=0then toreturn $$.26a
/*6*/ when ? interpret== '_=XOR' $u then return a && /*evaluate truth T.*/b
/*7*/ when ? _=changestr(1,_,= '_trueOR') /*convert 1──►_true*/ then return a | b
/*8*/ when ? _=changestr(0,_,= 'falseNOR') /*convert 0──►false*/ then return \ (a | b)
/*9*/ when ? == 'XNOR' _=insert then return \ (ptr,_,wordindex(_,words(_))-1)a && /*──►*/b)
/*a*/ when ? == say translate(_,,'_NOTB') then /*displayreturn truth\ tab*/b
/*b*/ when ? == 'BIMPA' end then /*z*/return \ (b & \a)
/*c*/ when ? == 'NOTA' end then /*y*/ return \ a
/*d*/ when ? == end'AIMPB' then /*x*/return \ (a & \b)
/*e*/ when ? end== 'NAND' then /*w*/ return \ (a & b)
/*f*/ when end? == 'TRUE' then /*v*/ return 1
end otherwise /*u*/ return -13
end /*select*/ /*t [↑] error, unknown function.*/</lang>
Some older REXXes don't have a &nbsp; '''changestr''' &nbsp; BIF, so one is included here &nbsp; ──► &nbsp; [[CHANGESTR.REX]].
end /*s*/
 
end /*r*/
{{out|output|text=&nbsp; when using the default inputs:}}
end /*q*/
 
end /*p*/
(Output is shown at three-quarter size.)
end /*o*/
<pre style="font-size:75%;height:115ex">
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; return
/*─────────────────────────────────────SCAN subroutine──────────────────*/
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
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
end /*j*/
return min(j,L)
/*─────────────────────────────────────changeFunc subroutine────────────*/
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"',")
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 subroutine──────────────────*/
bool: procedure; arg a,$,b
select
/*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
/*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 /*error.*/
end /*select*/</lang>
Some older REXXes don't have a &nbsp; '''changestr''' &nbsp; BIF, so one is included here ──► [[CHANGESTR.REX]].
<br><br>
'''output''' when using the default input
<pre style="height:50ex">
G H G ^ H ; XOR
───── ───── ───────────
Line 2,935 ⟶ 2,944:
true false ────► true
true true ────► false
 
 
I J i | j ; OR
Line 2,942 ⟶ 2,952:
true false ────► true
true true ────► true
 
 
G H G nxor H ; NXOR
Line 2,949 ⟶ 2,960:
true false ────► false
true true ────► true
 
 
K T k ! t ; NOR
Line 2,956 ⟶ 2,968:
true false ────► false
true true ────► false
 
 
P Q p & q ; AND
Line 2,963 ⟶ 2,976:
true false ────► false
true true ────► true
 
 
E F e ¡ f ; NAND
Line 2,971 ⟶ 2,985:
true true ────► false
 
 
S T U S | (T ^ U )
S T U S | (T ^ U)
───── ───── ───── ────────────
───── ───── ───── ───────────
false false false ────► false
false false true ────► true
Line 2,981 ⟶ 2,996:
true true false ────► true
true true true ────► true
 
 
P Q R (p=>q) v (q=>r)
Line 2,992 ⟶ 3,008:
true true false ────► true
true true true ────► true
 
 
A B C D A ^ (B ^ (C ^ D))
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/204832"