Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;;;; Created on 2011-03-09 19:46:53
- ; Updated to v0.1: 2011-08-05 23:40:51
- ;;;; The author is indebted to Sylwester (http://sylwester.no/)
- ;;;; for accidentally being my very first tester
- (defparameter *tape* (make-array 100 :initial-element 0))
- (defparameter *position* 0)
- (defparameter *userposition* 0)
- (defparameter *openbracket-appear* 0)
- (defparameter *closebracket-appear* 0)
- (defparameter loopback-appear 0) ;Piece of shit helper variable that doesn't even deserve its earmuffs
- (defparameter loopforward-appear 0)
- ;(defparameter *errors* (make-hash-table))
- ;;Defining error types:
- ; (setf (gethash 'input-type-str *errors*) '(Input cannot be of type string))
- ; (setf (gethash 'input-type-nil *errors*) '(Input cannot be of type null))
- ; (setf (gethash 'tape-string *errors*) '(Cannot concatenate string with number objects))
- ; (setf (gethash 'input-unknown *errors*) '(Input unknown or invalid))
- ;(defun err (code)
- ; (format t "~&Error:~s" (gethash *errors* code)))
- ; Get rid of this... Maybe
- (defparameter output-opcodes? nil)
- (defun output-opcodes (value)
- (if (not (null value))
- (setf output-opcodes? t)
- (setf output-opcodes?`nil)))
- (defun outputdata()
- (format t "~a" (code-char (aref *tape* *position*))))
- (defun readindata()
- (force-output *query-io*)
- (setf (aref *tape* *position*) (char-code (elt (string (read)) 0)))) ;only uppercase. bummer. I can't get READ-LINE to work in LispIDE >:c
- (defun turn-literal-input (literal-input)
- (coerce literal-input 'list)
- )
- (defun bf(userinput)
- (setf userinput (turn-literal-input userinput))
- (loop
- (if (not (< *userposition* (length userinput)))
- (return))
- (cond ((equal (nth *userposition* userinput) #\+)
- (incf (aref *tape* *position*))
- (if output-opcodes? (format t "OP1;")))
- ((equal (nth *userposition* userinput) #\-)
- (if (eql 0 (aref *tape* *position*))
- (return)
- (decf (aref *tape* *position*)))
- (if output-opcodes? (format t "OP2;")))
- ((equal (nth *userposition* userinput) #\>)
- (if (eql *position* (1- (length *tape*)))
- (setf *position* 0)
- (incf *position*))
- (if output-opcodes? (format t "OP3;")))
- ((equal (nth *userposition* userinput) #\<)
- (if (eql 0 *position*)
- (setf *position* (1- (length *tape*)))
- (decf *position*))
- (if output-opcodes? (format t "OP4;")))
- ((equal (nth *userposition* userinput) #\.)
- (outputdata)
- (if output-opcodes? (format t "OP5;")))
- ((equal (nth *userposition* userinput) #\,)
- (readindata)
- (if output-opcodes? (format t "OP6;")))
- ((equal (nth *userposition* userinput) #\!)
- (return)
- (if output-opcodes? (format t "OP7;")))
- ((equal (nth *userposition* userinput) #\[)
- (if output-opcodes? (format t "OP8;"))
- (incf *openbracket-appear*)
- (if (eql (aref *tape* *position*) 0)
- (loop
- (if (equal (nth *userposition* userinput) #\])
- (progn (incf loopforward-appear)
- (if (equal loopforward-appear *openbracket-appear*)
- (progn (if (not (eql *userposition* (1- (length userinput))))
- (incf *userposition*))
- (return)))))
- (incf *userposition*))))
- ((equal (nth *userposition* userinput) #\])
- (if output-opcodes? (format t "OP9;"))
- ;;Oh dear
- (incf *closebracket-appear*)
- (if (not (eql (aref *tape* *position*) 0))
- (loop
- (cond ((equal (nth *userposition* userinput) #\[)
- (incf loopback-appear)
- (if (eql loopback-appear *closebracket-appear*)
- (return))))
- (decf *userposition*)))))
- (incf *userposition*)
- )
- (if output-opcodes? (format t "EOF;;"))
- (setf *userposition* 0 *openbracket-appear* 0 *closebracket-appear* 0 loopback-appear 0 loopforward-appear 0)
- *tape*
- )
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement