alists and plists now

2019-07-05 01:26:00 +02:00
parent d576e7324f
commit e0aaf351c5
14 changed files with 646 additions and 106 deletions
@@ -13,10 +13,29 @@
 ;;        key1               key2
 ;;
 ;;        '(((key1 . value1) (key2 . value2)))
+
+;; plist:
+;;        [ |/]
+;;         |
+;;         V
+;;        [ | ]------------->[ | ]-------------> ...
+;;         |                  |
+;;         V                  V
+;;       :key1              value1
+;;
+;;        '((:key1 value1 :key2 value2))
+
 (define key-not-found-index -1)

 (define (make-alist)
-  '(()))
+  (set-type
+   '(())
+   :alist))
+
+(define (make-plist)
+  (set-type
+   '(())
+   :plist))

 (define (pprint-alist alist)
  (let ((associations (first alist)))
@@ -32,6 +51,19 @@
      (pprint-intern associations))
    (print ")\n")))

+(define (pprint-plist plist)
+  (let ((props (first plist)))
+    (define (pprint-intern props)
+      (when props
+        (printf "  "
+                (car props) "->"
+                (cadr props))
+        (pprint-intern (cddr props))))
+    (print "(")
+    (when props
+      (print "\n")
+      (pprint-intern props))
+    (print ")\n")))

 (define (alist-get alist key)
  (let ((associations (first alist)))
@@ -76,7 +108,8 @@

    (cond ((= index key-not-found-index) (error "key to remove was not found"))
          ((= index 0) (mutate alist (pair (cdar alist) ())))
-          (else (alist-remove!-internal alist index)))))
+          (else (alist-remove!-internal alist index))))
+  alist)


 (define (alist-set! alist key value)
@@ -93,4 +126,62 @@
            ((null? associations) (alist-set! alist key value))
            (else (alist-set-overwrite-intern
                   (rest associations) key value))))
-    (alist-set-overwrite-intern associations key value)))
+    (alist-set-overwrite-intern associations key value))
+  alist)
+
+
+(define (plist-get plist prop)
+  (let ((props (first plist)))
+    (define (plist-get-intern props prop)
+      (cond ((null? props)
+             (error "property was not found in plist"))
+            ((= (car props) prop)
+             (cadr props))
+            (else (plist-get-intern (cddr props) prop))))
+    (plist-get-intern props prop)))
+
+(define (plist-set! plist prop value)
+  (mutate plist (pair (pair prop (pair value (first plist))) ())))
+
+(define (plist-set-overwrite! plist prop value)
+  (let ((props (first plist)))
+    (define (plist-set-overwrite-intern props prop value)
+      (cond ((= (car props) prop)
+             (mutate (cdr props) (pair value (cddr props))))
+            ((null? props) (plist-set! plist prop value))
+            (else (plist-set-overwrite-intern
+                   (cddr props) prop value))))
+    (plist-set-overwrite-intern props prop value))
+  plist)
+
+(define (plist-find plist prop)
+  (let ((props (first plist)))
+    (define (plist-find-intern props prop current-index)
+      (cond ((null? props) key-not-found-index)
+            ((= (car props) prop) current-index)
+            (else (plist-find-intern (cddr props) prop
+                                     (+ 1 current-index)))))
+    (plist-find-intern props prop 0)))
+
+(define (plist-prop-exists? plist prop)
+  (not (= (plist-find plist prop)
+          key-not-found-index)))
+
+(define (plist-remove! plist prop)
+  (let ((index (plist-find plist prop)))
+    (define (plist-remove!-internal props index)
+      ;; reminder: we only get called if we are not replacing the
+      ;; first element in the alist
+      ;; reminder2: we know that the key exists
+      (if (= index 1)
+          ;; we want to remove the next one, so we set our
+          ;; cdr to the next next one
+           (mutate (cdar props) (pair (cadar props) ;; xD nice meme dude!!!
+                                      (cdr (cdr (cdr (cdar props))))))
+        ;; else cdr-recurse
+        (plist-remove!-internal (cddr props) (- index 1))))
+
+    (cond ((= index key-not-found-index) (error "prop to remove was not found"))
+          ((= index 0) (mutate plist (pair (cddar plist) ())))
+          (else (plist-remove!-internal plist index))))
+  plist)
@@ -1,3 +1,4 @@
+(import "alist.slime")
 (import "oo.slime")
 (import "math.slime")

@@ -17,8 +17,8 @@ condition is true.
 {{{example_end}}}
 "
  (if (= (rest body) ())
-      `(if ,condition @body)
-    `(if ,condition (begin @body))))
+      `(if ,condition @body nil)
+    `(if ,condition (begin @body) nil)))

 (define-syntax (unless condition :rest body)
    "Special form for when multiple actions should be done if a
@@ -57,13 +57,28 @@ condition is false."
        nil
      (if (= (first (first clauses)) 'else)
          (begin
-           (if (not (= () (rest clauses)))
+           (if (not (= (rest clauses) ()))
               (error "There are additional clauses after the else clause!")
             (pair 'begin (rest (first clauses)))))
        `(if ,(first (first clauses))
-              (begin @(rest (first clauses)))
-              ,(rec (rest clauses))))))
-    (rec clauses))
+             (begin @(rest (first clauses)))
+           ,(rec (rest clauses))))))
+  (rec clauses))
+
+
+(define-syntax (case var :rest clauses)
+  (define (rec clauses)
+    (if (= nil clauses)
+        nil
+      (if (= (first (first clauses)) 'else)
+          (begin
+           (if (not (= (rest clauses) ()))
+               (error "There are additional clauses after the else clause!")
+             (pair 'begin (rest (first clauses)))))
+        `(if (member? ,var ',(first (first clauses)))
+             (begin @(rest (first clauses)))
+           ,(rec (rest clauses))))))
+  (rec clauses))

 (define-syntax (define-special name-and-args :rest body)
  `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) @body)))
@@ -110,10 +125,24 @@ condition is false."
  (rec body))

 (define-syntax (apply fun seq)
-  "Applies the funciton to the sequence, as in calls the function with
+  "Applies the function to the sequence, as in calls the function with
 ithe sequence as arguemens."
  `(eval (pair ,fun ,seq)))

+(define-syntax (define-typed args :rest body)
+  (define (get-arg-names args)
+    (when args
+      (pair (first args)
+            (get-arg-names  (rest (rest args))))))
+  (let ((name        (first args))
+        (lambda-list (rest args))
+        (arg-names   (get-arg-names (rest args))))
+    `(define (,name @arg-names)
+       (assert-types= @lambda-list)
+       @body)))
+
+(define-typed (ttt a :number b :alist)
+  (printf a b))

 (define-syntax (define-package name :rest body)
  `(define ,(string->symbol (concat-strings (symbol->string name) "->"))
@@ -131,43 +160,62 @@ ithe sequence as arguemens."

 (define (null? x)
  "Checks if the argument is =nil=."
-  (= x nil))
+  (= x ()))
+
+(define (type=? obj typ)
+  "Checks if the argument =obj= is of type =typ="
+  (= (type obj) typ))
+
+(define (types=? :rest objs)
+  ;; TODO make inner rec functoin to avoid evalutating every time
+  (if objs
+      (begin
+       (assert (keyword? (first (rest objs))))
+       (if (type=? (first objs) (first (rest objs)))
+           (apply types=? (rest (rest objs)))
+         ()))
+      t))
+
+(define (assert-types= :rest objs)
+  (break)
+  (unless (apply types=? objs)
+    (error "assert-types=: types do not match")))

 (define (number? x)
  "Checks if the argument is a number."
-  (= (type x) :number))
+  (type=? x :number))

 (define (symbol? x)
  "Checks if the argument is a symbol."
-  (= (type x) :symbol))
+  (type=? x :symbol))

 (define (keyword? x)
  "Checks if the argument is a keyword."
-  (= (type x) :keyword))
+  (type=? x :keyword))

 (define (pair? x)
  "Checks if the argument is a pair."
-  (= (type x) :pair))
+  (type=? x :pair))

 (define (string? x)
  "Checks if the argument is a string."
-  (= (type x) :string))
+  (type=? x :string))

 (define (lambda? x)
  "Checks if the argument is a function."
-  (= (type x) :lambda))
+  (type=? x :lambda))

 (define (macro? x)
  "Checks if the argument is a macro."
-  (= (type x) :macro))
+  (type=? x :macro))

 (define (special-lambda? x)
  "Checks if the argument is a special-lambda."
-  (= (type x) :dynamic-macro))
+  (type=? x :dynamic-macro))

 (define (built-in-function? x)
  "Checks if the argument is a built-in function."
-  (= (type x) :built-in-function))
+  (type=? x :built-in-function))

 (define (callable? x)
  (or (lambda? x)
@@ -229,6 +277,12 @@ with (pair elem nil)."
      0
    (+ 1 (length (rest seq)))))

+(define (member? elem seq)
+  (when (pair? seq)
+    (if (= elem (first seq))
+        t
+      (member? elem (rest seq)))))
+
 (define (sublist-starting-at-index seq index)
  (cond ((< index 0)
         (error "sublist-starting-at-index: index must be positive"))
@@ -1,22 +1,30 @@
-(define (null? x) "Checks if the argument is =nil=." (= x nil))
+(define-typed (ttt a :number b :alist) (printf a b))

-(define (number? x) "Checks if the argument is a number." (= (type x) :number))
+(define (null? x) "Checks if the argument is =nil=." (= x ()))

-(define (symbol? x) "Checks if the argument is a symbol." (= (type x) :symbol))
+(define (type=? obj typ) "Checks if the argument =obj= is of type =typ=" (= (type obj) typ))

-(define (keyword? x) "Checks if the argument is a keyword." (= (type x) :keyword))
+(define (types=? :rest objs) (if objs (begin (assert (keyword? (first (rest objs)))) (if (type=? (first objs) (first (rest objs))) (apply types=? (rest (rest objs))) ())) t))

-(define (pair? x) "Checks if the argument is a pair." (= (type x) :pair))
+(define (assert-types= :rest objs) (break) (unless (apply types=? objs) (error "assert-types=: types do not match")))

-(define (string? x) "Checks if the argument is a string." (= (type x) :string))
+(define (number? x) "Checks if the argument is a number." (type=? x :number))

-(define (lambda? x) "Checks if the argument is a function." (= (type x) :lambda))
+(define (symbol? x) "Checks if the argument is a symbol." (type=? x :symbol))

-(define (macro? x) "Checks if the argument is a macro." (= (type x) :macro))
+(define (keyword? x) "Checks if the argument is a keyword." (type=? x :keyword))

-(define (special-lambda? x) "Checks if the argument is a special-lambda." (= (type x) :dynamic-macro))
+(define (pair? x) "Checks if the argument is a pair." (type=? x :pair))

-(define (built-in-function? x) "Checks if the argument is a built-in function." (= (type x) :built-in-function))
+(define (string? x) "Checks if the argument is a string." (type=? x :string))
+
+(define (lambda? x) "Checks if the argument is a function." (type=? x :lambda))
+
+(define (macro? x) "Checks if the argument is a macro." (type=? x :macro))
+
+(define (special-lambda? x) "Checks if the argument is a special-lambda." (type=? x :dynamic-macro))
+
+(define (built-in-function? x) "Checks if the argument is a built-in function." (type=? x :built-in-function))

 (define (callable? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x)))

@@ -32,6 +40,8 @@

 (define (length seq) "Returns the length of the given sequence." (if (null? seq) 0 (+ 1 (length (rest seq)))))

+(define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq)))))
+
 (define (sublist-starting-at-index seq index) (cond ((< index 0) (error "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))

 (define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))
@@ -1,7 +1,7 @@
 (import "alist.slime")

 (define a (make-alist))
-;; a == ()
+;; a == (())

 (assert (= (first a) ()))

@@ -46,3 +46,56 @@
 (assert (= (length (first a)) 2))
 (assert (= (alist-get a 'key1) 'value1))
 (assert (= (alist-get a 'key2) 'value2))
+
+
+;; -------------
+;;
+;;     PLISTS
+;;
+;; -------------
+
+(define p (make-plist))
+;; p == (())
+
+(assert (= (first p) ()))
+
+(plist-set! p :key1 'value1)
+;; p == ((:key1 value1))
+
+(assert (=   (plist-get p :key1) 'value1))
+(assert      (plist-prop-exists? p :key1))
+(assert (not (plist-prop-exists? p :key2)))
+
+(plist-set! p :key2 'value2)
+;; p == ((:key2 value2,
+;;        :key1 value1))
+
+(assert (= (plist-get p :key2) 'value2))
+(assert (plist-prop-exists? p :key2))
+(assert (= (plist-find p :key2) 0))
+(assert (= (plist-find p :key1) 1))
+(assert (= (length (first p)) 4))
+
+(plist-set! p :key1 'value3)
+;; p == ((:key1 value3,
+;;        :key2 value2,
+;;        :key1 value1))
+
+(assert (= (length (first p)) 6))
+(assert (= (plist-get p :key1) 'value3))
+
+(plist-set-overwrite! p :key1 'value4)
+;; p == ((:key1 value4,
+;;        :key2 value2,
+;;        :key1 value1))
+
+(assert (= (length (first p)) 6))
+(assert (= (plist-get p :key1) 'value4))
+
+(plist-remove! p :key1)
+;; p == ((:key2 value2,
+;;        :key1 value1))
+
+(assert (= (length (first p)) 4))
+(assert (= (plist-get p :key1) 'value1))
+(assert (= (plist-get p :key2) 'value2))
@@ -0,0 +1,37 @@
+(define (test-cond x)
+  (cond ((< 0 x) +1)
+        ((> 0 x) -1)
+        (else 0)))
+
+(assert (= (test-cond 10)  1))
+(assert (= (test-cond 1)   1))
+(assert (= (test-cond 123) 1))
+
+(assert (= (test-cond -10)  -1))
+(assert (= (test-cond -1)   -1))
+(assert (= (test-cond -123) -1))
+
+(assert (= (test-cond  0) 0))
+(assert (= (test-cond -0) 0))
+(assert (= (test-cond +0) 0))
+
+
+(define (test-case x)
+  (case x
+    ((a b 3) 1)
+    ((4 5 6) -1)
+    (else 'xD)))
+
+
+(assert (= (test-case 'a) 1))
+(assert (= (test-case 'b) 1))
+(assert (= (test-case 3)  1))
+
+(assert (= (test-case 4) -1))
+(assert (= (test-case 5) -1))
+(assert (= (test-case 6) -1))
+
+(assert (= (test-case 0)    'xD))
+(assert (= (test-case 1)    'xD))
+(assert (= (test-case :asd) 'xD))
+