From 6e7cdcd4280f5330229ec9c943b9caf090846452 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Wed, 18 Nov 2020 23:59:17 +0000 Subject: Checkpointing from my Mac --- abs-syn.lsp | 23 +++++++++++++++++++++++ basic.lsp | 15 +++++++++++++-- bitmap.lsp | 4 ++-- dbc.lsp | 3 ++- lex.lsp | 38 +++++++++++++++++++++++++++----------- loot.lsp | 41 +++++++++++++++++++++++++++++++++++++++++ parse.lsp | 43 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 151 insertions(+), 16 deletions(-) create mode 100755 loot.lsp create mode 100644 parse.lsp diff --git a/abs-syn.lsp b/abs-syn.lsp index a339a47..5963381 100644 --- a/abs-syn.lsp +++ b/abs-syn.lsp @@ -1,3 +1,25 @@ +(defpackage #:abs-syn + (:use #:openlisp) + (:export + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #: + #:priority-uop + #:priority-binop)) +(in-package #:abs-syn) + ;; If these were only C enums, without any payload, I'd just use symbols and (error) in the t case. ;; But classes seem better for the associated data, in discriminated unions. @@ -35,3 +57,4 @@ ((eql bin-op 'mod) 4) ((member bin-op '(equal less lesseq great greateq diff)) 3) ((member bin-op '(and or)) 2))) +(provide "abs-syn") diff --git a/basic.lsp b/basic.lsp index 571d4a6..7f13acd 100644 --- a/basic.lsp +++ b/basic.lsp @@ -1,9 +1,19 @@ -#!/home/snuc/openlisp-10.9.0/uxlisp -shell +#!/Users/dbane/openlisp-11.0.0/uxlisp -shell + +(require "abs-syn") +(require "lex") +(require "parse") +(defpackage #:basic + (:use #:openlisp) + (:export + #:main)) +(in-package #:basic) ;;; Not sure yet if it's a good idea or not, ;;; but I'm trying to keep the number of top-level functions the same as in OCaml. (defun one-command (st) + (format (standard-output) "> ") (with-handler #'error-handler (let ((l parse (read-line))) (case (car l) @@ -18,9 +28,10 @@ (defun main () (catch 'end (lambda () - (format (standard-output) "OpenCOMAL version 0.4~%~%") + (format (standard-output) "BASIC version 0.1~%~%") (for ((st (create (class )))) (()) (format (standard-output) "> ") (catch 'error (one-command st))))) (format (standard-output) "See you later...~%")) +(provide "basic") diff --git a/bitmap.lsp b/bitmap.lsp index e4cdea3..41d3f64 100644 --- a/bitmap.lsp +++ b/bitmap.lsp @@ -79,9 +79,9 @@ ;;; Read a PPM file -(defconstant +whitespaces-chars+ '(#\SPACE #\RETURN #\TAB #\NEWLINE #\LINEFEED)) +(defconstant +whitespace-chars+ '(#\SPACE \#carriage-return #\TAB #\NEWLINE)) -(defun read-header-chars (stream &optional (delimiter-list +whitespaces-chars+)) +(defun read-header-chars (stream &optional (delimiter-list +whitespace-chars+)) (do ((c (read-char stream nil :eof) (read-char stream nil :eof)) (vals nil (if (or (null c) (char= c #\#)) vals (cons c vals)))) ;;don't collect comment chars diff --git a/dbc.lsp b/dbc.lsp index 48f1d6f..fc6e5d0 100644 --- a/dbc.lsp +++ b/dbc.lsp @@ -4,7 +4,8 @@ (defcontract average-of-absolutes (values) (:in () (assure values) - (> (length values) 0)) ; Redundant? + (> (length values) 0)) ; Not redundant, nil is an instance of . + ; Could have used instead I guess. (:out (res) (assure res) (>= res 0)) diff --git a/lex.lsp b/lex.lsp index 52eb822..9f10a03 100644 --- a/lex.lsp +++ b/lex.lsp @@ -1,4 +1,20 @@ -(defclass () ((string :initarg :s :accessor string) +(defpackage #:lex + (:use #:openlisp) + (:export + #: + #: + #: + #:)) +(in-package #:lex) + +(defclass () () (:abstractp t)) +(defclass () ((int :reader int))) +(defclass () ((ident :reader ident))) +(defclass () ((lsymbol :reader lsymbol))) +(defclass () ((lstring :reader lstring))) +(defclass () ()) + +(defclass () ((string :initarg s :accessor string) (current :initform 0 :accessor current) (size :accessor size))) @@ -26,16 +42,16 @@ (defgeneric extract-int (cl)) (defmethod extract-int ((cl )) - ;; TODO: flet? - (let ((is-int (lambda (x) - (and (char>= x #\0) (char<= x #\9))))) - (convert (extract is-int cl) ))) + (flet ((is-int (x) + (and (char>= x #\0) (char<= x #\9)))) + (convert (extract is-int cl) ))) (defgeneric extract-ident (cl)) (defmethod extract-ident ((cl )) - (let ((is-alpha-num (lambda (x) - (or (and (char>= x #\a) (char<= x #\z)) - (and (char>= x #\A) (char<= x #\Z)) - (and (char>= x #\0) (char<= x #\9)) - (char= x #\_))))) - (extract is-alpha-num))) + (flet ((is-alpha-num (x) + (or (and (char>= x #\a) (char<= x #\z)) + (and (char>= x #\A) (char<= x #\Z)) + (and (char>= x #\0) (char<= x #\9)) + (char= x #\_)))) + (extract is-alpha-num))) +(provide "lex") diff --git a/loot.lsp b/loot.lsp new file mode 100755 index 0000000..6192dbf --- /dev/null +++ b/loot.lsp @@ -0,0 +1,41 @@ +;;; Port of https://en.wikipedia.org/wiki/ModernPascal#Code_Sample[3]. +;;; And then to CL. +;;; I prefer my version. +(defconstant +max-probability+ 1000) +;; Because this is a simple enum and not a full sum/product type, +;; I use symbols instead of CLOS. +(defconstant +loot-type+ (vector 'bloodstone 'copper 'emeraldite 'gold + 'heronite 'platinum 'shadownite 'silver + 'soranite 'umbrarite 'cobalt 'iron + 'nothing)) +(defclass () ((probabilities :accessor probabilities))) +(defgeneric choose (self)) +(defmethod choose ((self )) + (let ((random-value (random (- +max-probability+ 1)))) + (do ((loop 0 (+ loop 1))) + ((>= (elt (probabilities self) (mod loop 13)) random-value) (elt +loot-type+ (mod loop 13)))))) +(defmethod initialize-instance :after ((self ) &rest initargs) + (setf (probabilities self) (vector 10 77 105 125 142 159 172 200 201 202 216 282 +max-probability+))) +(defun as-string (l) + ;; Could use assoc here, but this is closer to the original. + ;; Also saves translating nil to "". + (case l + ((bloodstone) "Bloodstone") + ((copper) "Copper") + ((emeraldite) "Emeraldite") + ((gold) "Gold") + ((heronite) "Heronite") + ((platinum) "Platinum") + ((shadownite) "Shadownite") + ((silver) "Silver") + ((soranite) "Soranite") + ((umbrarite) "Umbrarite") + ((cobalt) "Cobalt") + ((iron) "Iron") + (t ""))) +(defun main () + (let ((loot (make-instance (find-class ')))) + (do ((n 0 (+ n 1))) + ((> n 99)) + (format *standard-output* "~A~%" (as-string (choose loot)))))) +(main) diff --git a/parse.lsp b/parse.lsp new file mode 100644 index 0000000..9bedee3 --- /dev/null +++ b/parse.lsp @@ -0,0 +1,43 @@ +(defpackage #:parse + (:use #:openlisp #:lex #:abs-syn) + (:export + #:parse)) +(in-package #:parse) + +(defclass () () (:abstractp t)) +(defclass () ((expr :accessor expr))) +(defclass () ((bin-op :accessor bin-op))) +(defclass () ((unr-op :accessor unr-op))) +(defclass (") 'great))) + +(defun parse (str) + (let* ((cl (init-lex str)) + (tok (lexer cl))) + (cond ((instancep tok (class )) + (make-instance (class ) 'n n 'c (parse-cmd cl))) + ((instancep tok (class )) + (cond ((string= (ident tok) "LIST") + (create (class ))) + ((string= (ident tok) "RUN") + (create (class ))) + ((string= (ident tok) "END") + (create (class ))) + (t (error "Parse error")))) + (t (error "Parse error"))))) +(provide "parse") -- cgit 1.4.1-2-gfad0