#-(and) " P47 (*) Truth tables for logical expressions (2). Continue problem P46 by defining and/2, or/2, etc as being operators. This allows to write the logical expression in the more natural way, as in the example: A and (A or not B). Define operator precedence as usual; i.e. as in Java. Example: * table(A,B, A and (A or not B)). true true true true fail true fail true fail fail fail fail " ;; Again, this question doesn't make much sense in lisp. ;; ;; To have fun, we could interpret it as requesting parsing a list in ;; infix notation and translating it to prefix notation. ;; ;; (infix-to-prefix '(a and (a or not b))) --> (and a (or a (not b))) ;; ;; but notice that we need a list anyways, and that parenthesized ;; subexpressions are actually sublists, there's no parentheses to be ;; parsed. ;; ;; On the other hand, we could write a full lexer and parser for ;; prolog syntax, but that would be out of scope for this exercise. ;; ;; ;; Java operator precedences are: ;; ;; Priority Operators Operation Associativity ;; 1 [ ] array index left ;; () method call ;; . member access ;; 2 ++ pre- or postfix increment right ;; -- pre- or postfix decrement ;; + - unary plus, minus ;; ~ bitwise NOT ;; ! boolean (logical) NOT ;; (type) type cast ;; new object creation ;; 3 * / % multiplication, division, remainder left ;; 4 + - addition, substraction left ;; + string concatenation ;; 5 << signed bit shift left left ;; >> signed bit shift right ;; >>> unsigned bit shift right ;; 6 < <= less than, less than or equal to left ;; > >= greater than, greater than or equal to ;; instanceof reference test ;; 7 == equal to left ;; != not equal to ;; 8 & bitwise AND left ;; & boolean (logical) AND ;; 9 ^ bitwise XOR left ;; ^ boolean (logical) XOR ;; 10 | bitwise OR left ;; | boolean (logical) OR ;; 11 && boolean (logical) AND left ;; 12 || boolean (logical) OR left ;; 13 ? : conditional right ;; 14 = assignment right ;; *= /= += -= %= ;; <<= >>= >>>= ;; &= ^= |= combinated assignment ;; (operation and assignment) ;; ;; There are no NAND, NOR, EQU, or IMPL, but there are several AND and ;; OR, with different precedences! What a fucking problem statement! ;; ;; So we will write a parser that is parameterized by the precedences, ;; and we'll see later what is needed. ;; For this, we use a simple recursive-descend parser generator: (load "rdp.lisp") (use-package :com.informatimago.rdp) ;; Prefix or suffix operators must have arity = 1, and therefore ;; don't have any specific associativity dirrection other than their ;; being prefix or suffix. ;; x not not not not/1 suffix (((x not) not) not) ;; not not not x not/1 prefix (not (not (not x))) ;; Infix operators must have an arity > 1 (usually 2), and must have ;; either left or right associativity. ;; ;; a op b op c op/2 left (a op b) op b ;; a op b op c op/2 right a op (b op c) ;; We define an operator level as a list containing the precedence ;; level (smaller number, higher precendence), the arity, the ;; position-and-associativity (:prefix, :suffix, :infix-left or ;; :infix-right), and the list of operators: (defstruct (level (:type list)) (precedence 0 :type integer) (arity 0 :type integer) (position :prefix :type (member :prefix :suffix :infix-left :infix-right)) (operators '() :type list)) (defun leftify (operators expr) " Transforms a right-associative operation tree EXPR of OPERATORS, into a leflt-associative one. (op a (op b c)) --> (op (op a b) c) " (labels ((flatten (expr flattened) (cond ((atom expr) (cons expr flattened)) ((member (first expr) operators) (flatten (third expr) (list* (first expr) (second expr) flattened))) (t (cons expr flattened)))) (unflatten-left (expr flattened) (if (endp flattened) expr (unflatten-left (list (first flattened) expr (second flattened)) (rest (rest flattened)))))) (let ((flattened (nreverse (flatten expr '())))) (unflatten-left (first flattened) (rest flattened))))) (defun production-var (n) "Makes a production variable $n" (intern (format nil "$~A" n))) (defun token-to-lisp (token) ;; rdp tokens are (terminal "text" position) ;; Since we take care of naming our operator terminals as lisp ;; operators, we can just extract them from the tokens. ;; For variables, we cl:read the text. (if (atom token) token (case (first token) ((identifier) (read-from-string (second token))) ((true) 't) ((fail) 'nil) (otherwise (first token))))) (defun generate-operator-level-rules (non-terminal inferior-non-terminal level) "Generates a grammar rule to parse the given operator level, and build the corresponding expression tree." (let ((op-non-terminal (intern (format nil "~A-OP" non-terminal)))) (ecase (level-position level) ((:prefix) `((--> ,non-terminal (alt ,op-non-terminal ,inferior-non-terminal) :action $1) (--> ,op-non-terminal (alt ,@(level-operators level)) ,@(make-list (level-arity level) :initial-element inferior-non-terminal) ;; (opt (seq (alt ,@(level-operators level)) ;; ,@(make-list (level-arity level) :initial-element inferior-non-terminal)) ;; ,inferior-non-terminal) :action (list (token-to-lisp $1) ,@(loop :repeat (level-arity level) :for i :from 2 :collect (production-var i)))))) ((:suffix) `((--> ,non-terminal (alt ,op-non-terminal ,inferior-non-terminal) :action $1) (--> ,op-non-terminal ,@(make-list (level-arity level) :initial-element inferior-non-terminal) (alt ,@(level-operators level)) :action (list (token-to-lisp ,(production-var (1+ (level-arity level)))) ,@(loop :repeat (level-arity level) :for i :from 1 :collect (production-var i)))))) ;; We're using a recursive-descend parser, so we can have only ;; right-recursive rules. Therefore we will just collect the list ;; of operations at the grammar level, and implement the ;; associativity in the action. ;; ;; (--> factor ;; term op factor) ; :infix-right term op (term op term) ;; ;; (--> factor ;; factor op term) ; :infix-left (term op term) op term ((:infix-left :infix-right) (assert (= 2 (level-arity level)) (level) "Infix operators with an arity different from 2 are not implemented.") `((--> ,non-terminal ,op-non-terminal :action ,(if (eql :infix-left (level-position level)) `(if (and (listp $1) (= 3 (length $1))) (leftify ',(level-operators level) $1) $1) `$1)) (--> ,op-non-terminal ,inferior-non-terminal (opt (alt ,@(level-operators level)) ,op-non-terminal) :action (if $2 (destructuring-bind (op right) $2 (list (token-to-lisp op) $1 right)) $1))))))) (defun generate-operator-grammar (name operator-levels) "Generate a RDP grammar for the operators given in OPERATOR-LEVELS. This will create a function named PARSE-{NAME}." (let* ((levels (sort (copy-list operator-levels) (function >) :key (function level-precedence))) (non-terminals (nconc (loop :for level :in levels :collect (intern (format nil "~{~A~^/~}-FACTOR" (level-operators level)))) (list 'term))) (terminals (nconc (mapcan (lambda (level) (mapcar (lambda (operator) (list operator (string-downcase operator))) (level-operators level))) levels) '((true "true") (fail "fail") (identifier "[A-Za-z][-A-Za-z0-9]*")))) (rules `((--> ,(first (last non-terminals)) (alt constant variable parenthesized-expression) :action $1) ;; We need to wrap terms in an identity operator to ;; avoid lefitification of the first non-terminal: ;; (a impl b) impl (c impl d) must stay that way. (--> parenthesized-expression "(" ,(first non-terminals) ")" :action (list 'identity $2)) (--> constant (alt true fail) :action (token-to-lisp $1)) (--> variable identifier :action (token-to-lisp $1)) ,@(reduce (function append) (mapcar (function generate-operator-level-rules) non-terminals (rest non-terminals) levels) :from-end t)))) #+debug (print `(com.informatimago.rdp:generate-grammar ,name :terminals ',terminals :start ',(first non-terminals) :rules ',rules)) (com.informatimago.rdp:generate-grammar name :terminals terminals :start (first non-terminals) :rules rules))) (defparameter *operators* '(( 2 1 :prefix (not)) ( 8 2 :infix-left (and nand)) ( 9 2 :infix-left (xor equ)) (10 2 :infix-left (or nor)) (12 2 :infix-left (impl)))) (generate-operator-grammar 'logical-expression *operators*) (defun test/operator-grammar () (loop :for (source expected) :in '(("a" a) ("true" t) ("fail" nil) ("a and b" (and a b)) ("(a impl b) impl (c impl d)" (impl (identity (impl a b)) (identity (impl c d)))) ("a and b and c and d" (AND (AND (AND a b) c) D)) ("a and b and c or d and e and f or g and i and j" (or (or (and (and a b) c) (and (and d e) f)) (and (and g i) j))) ("(a xor b) equ (not a xor not b)" (equ (identity (xor a b)) (identity (xor (not a) (not b)))))) :do (let ((result (handler-case (PARSE-LOGICAL-EXPRESSION source) (error (err) (princ err) (terpri) :error)))) (assert (equal result expected) (source) "Parsing the logical expression ~S~% gave ~S ~%instead of expected ~S" source result expected))) :success) (defun remove-identity (expr) (cond ((atom expr) expr) ((eql 'identity (first expr)) (remove-identity (second expr))) (t (cons (first expr) (mapcar (function remove-identity) (rest expr)))))) ;; (table 'a 'b (remove-identity (parse-logical-expression "a and (a or not b)"))) ;; true true true ;; true fail true ;; fail true fail ;; fail fail fail ;; --> NIL ;;;; THE END ;;;;