prefix-infix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
   2 ;;;; Code adapted from Paradigms of AI Programming
   3 ;;;; Copyright (c) 1991 Peter Norvig
   4 ;;;; Some derived portions (C) 2008 John Connors
   5
   6 (in-package :cl-tuples)
   7
   8 ;;; From student.lisp:
   9 (defstruct (rule (:type list)) pattern response)
  10 (defstruct (expression (:type list)
  11                 (:constructor mkexp (lhs op rhs)))
  12   op lhs rhs)
  13
  14 (defun expression-p (x) (consp x))
  15 (defun expression-args (x) (rest x))
  16
  17 (defun binary-expression-p (x)
  18   (and (expression-p x) (= (length (expression-args x)) 2)))
  19
  20 (defun prefix->infix (expression)
  21   "Translate prefix to infix expressions."
  22   (if (atom expression) expression
  23       (mapcar #'prefix->infix
  24               (if (binary-expression-p expression)
  25                   (list (expression-lhs expression) (expression-op expression) (expression-rhs expression))
  26                   expression))))
  27
  28 ;; Define x+ and y+ as a sequence:
  29 (pat-match-abbrev 'x+ '(?+ x))
  30 (pat-match-abbrev 'y+ '(?+ y))
  31
  32 ;; Define n and m as numbers; s as a non-number:
  33 (pat-match-abbrev 'n '(?is n numberp))
  34 (pat-match-abbrev 'm '(?is m numberp))
  35 (pat-match-abbrev 's '(?is s not-numberp))
  36
  37 ;; defint t as a tuple-type
  38 (pat-match-abbrev 'v '(?is ?v tuple-typep))
  39
  40
  41 (defparameter *infix->prefix-rules*
  42   (mapcar #'expand-pat-match-abbrev
  43     '(((- x+)    (- x))
  44       ((+ x+)    (+ x))
  45       ((x+ + y+) (+ x y))
  46       ((x+ - y+) (- x y))
  47       ((d y+ / d x) (d y x))        ;*** New rule
  48       ((Int y+ d x) (int y x))      ;*** New rule
  49       ((x+ * y+) (* x y))
  50       ((x+ / y+) (/ x y))
  51       ((x+ ^ y+) (^ x y))))
  52   "Rules to translate from infix to prefix")
  53
  54
  55 (defun infix->prefix (expression)
  56   "Translate an infix expression into prefix notation."
  57   ;; Note we cannot do implicit multiplication in this system
  58   (cond ((atom expression) expression)
  59         ((= (length expression) 1) (infix->prefix (first expression)))
  60         ((rule-based-translator expression *infix->prefix-rules*
  61            :rule-if #'rule-pattern :rule-then #'rule-response
  62            :action
  63            #'(lambda (bindings response)
  64                (identity (list :bindings bindings :response response)))))))
  65
  66 (defun infix->prefix (expression)
  67   "Translate an infix expression into prefix notation."
  68   ;; Note we cannot do implicit multiplication in this system
  69   (cond ((atom expression) expression)
  70         ((= (length expression) 1) (infix->prefix (first expression)))
  71         ((rule-based-translator expression *infix->prefix-rules*
  72            :rule-if #'rule-pattern :rule-then #'rule-response
  73            :action
  74            #'(lambda (bindings response)
  75                (sublis (mapcar
  76                          #'(lambda (pair)
  77                              (cons (first pair)
  78                                    (infix->prefix (rest pair))))
  79                          bindings)
  80                        response))))
  81         ((symbolp (first expression))
  82          (list (first expression) (infix->prefix (rest expression))))
  83         (t (error "Illegal expression"))))
  84