Version 8.1

README.md

@@ -19,7 +19,7 @@
     <p style="text-align: center;"><br>
     </p>
     <h1 style="text-align: center;"><b><span style="color: #000099;">Scheme+</span></b><b><span
-          style="color: #999999;"> <font size="+2">version 7.9 for Guile Scheme<br>
+          style="color: #999999;"> <font size="+2">version 8.1 for Guile Scheme<br>
           </font></span></b></h1>
     <p style="text-align: center;">
 	Display options for viewing this documentation:<br>

SRFI-105.scm

@@ -14,6 +14,15 @@
 
 (define slice-optim #t)
 
+;; library procedures and macro
+(define insert cons)
+
+;; insert and set 
+(define-syntax insert-set!
+  (syntax-rules ()
+    ((_ expr var)
+     (set! var (insert expr var)))))
+
 
   ; ------------------------------
   ; Curly-infix support procedures
@@ -78,6 +87,124 @@
      (#t  (transform-mixed-infix lyst))))
 
 
+
+;; usefull procedures and macro for the next part of code
+(define (then=? arg)
+  (or (equal? arg 'then) (equal? arg 'THEN)))
+
+(define (else=? arg)
+  (or (equal? arg 'else) (equal? arg 'ELSE)))
+
+
+;; > (if #f else 3)
+;; 3
+;; > (if #t else 3)
+;; > (if #t 2 else 3)
+;; 2
+;; > (if #t then 2 else 3)
+;; 2
+;; > (if #f then 2 else 3)
+;; 3
+;; > (if #f then 1 2 else 3 4)
+;; 4
+;; > (if #t then 1 2 else 3 4)
+;; 2
+;; > (if #t 1 2 3)
+;; 3
+;; > (if #t then 1 2 else 3 4 then 5)
+;; . . SRFI-105.rkt:181:17: if: then after else near : '(then 5)
+;; > (if #t then 1 2 else 3 4 else 5)
+;; . . SRFI-105.rkt:181:17: if: 2 else inside near: '(else 5)
+;; > (if #t else 1 2 then 3 4)
+;; . . SRFI-105.rkt:181:17: if: then after else near : '(then 3 4)
+;; > (if #t then 1 2 then 3 4)
+;; . . SRFI-105.rkt:181:17: if: 2 then inside near: '(then 3 4)
+(define (call-parse-if-args Largs) ; Largs = (test e1 ...)
+
+  ;;(display "Largs=") (display Largs) (newline)
+  (define lenL (length Largs))
+
+  (when (< lenL 2)
+	(error "if: too few arguments:" Largs))
+
+  (define test (car Largs))
+  (define e1 (cadr Largs))
+
+  ; deal with the old 2 args 'if' but modified
+  (condx ((and (= lenL 2) (then=? e1))
+	  (error "if: syntax error,found (if test then) only: near " Largs))
+	 ((and (= lenL 2) (else=? e1))
+	  (error "if: syntax error,found (if test else) only: near " Largs))
+	 ((= lenL 2) `(when ,test ,e1)) ; (if test e1)
+	 (exec (define e2 (third Largs)))
+	 ((and (= lenL 3) (then=? e1)) `(when ,test ; (if test then e2)
+					      ,e2))
+	 ((and (= lenL 3) (else=? e1)) `(unless ,test ; (if test else e2)
+						,e2))
+	 ((= lenL 3) `(if ,test
+			  ,e1
+			  ,e2))
+
+	 (else
+
+	  (define L-then '())
+	  (define L-else '())
+	  (define cpt-then 0)
+	  (define cpt-else 0)
+
+	  (define (parse-if-args L)
+
+	    (condx ((null? L) (set! L-then (reverse L-then))
+		              (set! L-else (reverse L-else)))
+
+		   (exec (define ec (car L))
+			 (define rstL (cdr L)))
+
+		   ((then=? ec) (when (= cpt-else 1)
+				      (error "if: then after else near :" L))
+		                (when (= cpt-then 1)
+				      (error "if: 2 then inside near:" L))
+		                (set! cpt-then (+ 1 cpt-then))
+		                (parse-if-args rstL)) ; recurse
+
+		   ((else=? ec) (when (= cpt-else 1)
+				      (error "if: 2 else inside near:" L))
+		                (set! cpt-else (+ 1 cpt-else))
+		                (parse-if-args rstL)) ; recurse
+
+
+		   ((and (>= cpt-then 1) (= cpt-else 0)) (insert-set! ec L-then)
+		                                         (parse-if-args rstL)) ; recurse
+
+
+		   ((>= cpt-else 1) (insert-set! ec L-else)
+		                    (parse-if-args rstL))  ; recurse
+
+		   (else ; start with 'then' directives but without 'then' keyword !
+		    ;; i allow this syntax but this is dangerous:  risk of confusion with regular scheme syntax
+
+		    (insert-set! ec L-then)
+
+		    (set! cpt-then 1)
+		    (parse-if-args rstL)))) ; recurse
+
+	    (define Lr (cdr Largs)) ; list of arguments of 'if' without the test
+
+	    (parse-if-args Lr) ; call the parsing of arguments
+
+	    (cond ((null? L-then) `(unless ,test
+					   ,@L-else))
+		  ((null? L-else) `(when ,test
+					 ,@L-then))
+		  (else `(if ,test
+			     (let ()
+			       ,@L-then)
+			     (let ()
+			       ,@L-else)))))))
+
+
+
+
   ; ------------------------------------------------
   ; Key procedures to implement neoteric-expressions
   ; ------------------------------------------------
@@ -103,27 +230,39 @@
         ((or (eq? c #\)) (eq? c #\]) (eq? c #\}))
           (read-char port)
           (read-error "Bad closing character"))
+
         (#t
-          (let ((datum (my-read port)))
-            (cond
-	     ;; processing period . is important for functions with variable numbers of parameters: (fct arg1 . restargs)
-	     ((eq? datum (string->symbol (string #\.))) ;; only this one works with Racket Scheme
-               ;;((eq? datum '.) ;; do not works with Racket Scheme
-               ;;((eq? datum 'period) ;; this one annihilate the processing: datum will never be equal to 'period !
-                 (let ((datum2 (my-read port)))
-                   (consume-whitespace port)
-                   (cond
-                     ((eof-object? datum2)
-                      (read-error "Early eof in (... .)\n")
-                      '())
-                     ((not (eqv? (peek-char port) stop-char))
-                      (read-error "Bad closing character after . datum"))
-                     (#t
-                       (read-char port)
-                       datum2))))
-               (#t
-                   (cons datum
-                     (my-read-delimited-list my-read stop-char port)))))))))
+	 (let ((datum (my-read port)))
+	   (cond
+	    ;; processing period . is important for functions with variable numbers of parameters: (fct arg1 . restargs)
+	    ((eq? datum (string->symbol (string #\.))) ;; only this one works
+	     (let ((datum2 (my-read port)))
+	       (consume-whitespace port)
+	       (cond
+		((eof-object? datum2)
+		 (read-error "Early eof in (... .)\n")
+		 '())
+		((not (eqv? (peek-char port) stop-char))
+		 (read-error "Bad closing character after . datum"))
+		(#t
+		 (read-char port)
+		 datum2))))
+
+	    (#t
+	     ;; here we get a symbolic scheme expression
+	     (let ((datum2 (cons datum
+				 (my-read-delimited-list my-read stop-char port))))
+
+	       (when (and (list? datum2)
+			  (not (null? datum2))
+			  (equal? (car datum2) 'if))
+
+		     (define datum3 (call-parse-if-args (cdr datum2)))
+
+		     (set! datum2 datum3))
+
+	       datum2))))))))
+
 
 
 

Scheme+.html

@@ -23,7 +23,7 @@ <h2 style=" text-align: center;">Damien Mattei<br>
     <p style="text-align: center;"><br>
     </p>
     <h1 style="text-align: center;"><b><span style="color: #000099;">Scheme+</span></b><b><span
-          style="color: #999999;"> <font size="+2">version 7.9 for Guile Scheme<br>
+          style="color: #999999;"> <font size="+2">version 8.1 for Guile Scheme<br>
           </font></span></b></h1>
     <p style="text-align: center;"> </p>
     <p style="text-align: center;"><br>

Scheme+.scm

@@ -1,6 +1,6 @@
 ;; Scheme+.scm
 
-;; version 7.9
+;; version 8.1
 
 ;; author: Damien MATTEI
 

Scheme+io.html

@@ -83,7 +83,7 @@ <h2 style=" text-align: center;">Damien Mattei<br>
         no room for doubts must have no room for thoughts either."</i> -<a href="https://www.ics.uci.edu/%7Epattis/" target="_blank">R. Patti</a></p>
     <p style="text-align: center;"><br>
     </p>
-    <h1 style="text-align: center;"><b><span style="color: #000099;">Scheme+</span></b><b><span style="color: #999999;"> <font size="+2">version 7.9 for Guile Scheme<br>
+    <h1 style="text-align: center;"><b><span style="color: #000099;">Scheme+</span></b><b><span style="color: #999999;"> <font size="+2">version 8.1 for Guile Scheme<br>
           </font></span></b></h1>
     <p style="text-align: center;">
 	Display options for viewing this documentation:<br><br>

curly-infix2prefix4guile.scm

@@ -25,10 +25,11 @@
 
 
 ;;(use-modules (ice-9 textual-ports)) ;; allow put-back characters
-(use-modules (ice-9 pretty-print))
-(use-modules (srfi srfi-31)) ;; rec
+(use-modules (ice-9 pretty-print)
+	     (srfi srfi-31) ; rec
+	     (srfi srfi-1)) ; first ,third 
 
-(include "first-and-rest.scm")
+(include "rest.scm")
 (include "operation-redux.scm")
 (include "optimize-infix.scm")
 (include "assignment-light.scm")
@@ -38,8 +39,13 @@
 (include "def.scm")
 (include "optimize-infix-slice.scm")
 
+(include "when-unless.scm")
+(include "while-do.scm")
+
 (define stderr (current-error-port))
 
+(include "condx.scm")
+
 (include "SRFI-105.scm")
 
 (define srfi-105 #f)

examples/SssDyna+.scm

@@ -406,6 +406,43 @@
   s) ;; return boolean value
 
 
+
+;; scheme@(guile-user)> (subset-sum-dynamic-new-syntax L-init t-init)
+;; $1 = #t
+(def (subset-sum-dynamic-new-syntax L t)
+
+  (declare ls dyn c R s) ;; declare multiple variables
+
+  {ls <- (length L)}
+  {dyn <- dyna[ls t]} ;; dyna is a toplevel defined array
+
+  ;; dyna[ls t] means : 0: unknown solution, 1: solution found, 2: no solution
+
+  (if {dyn <> 0} ;; IF or WHEN : it is the same thing here (only one statement)
+      (return (one? dyn)))
+
+  (if (null? L) then
+      {dyna[ls t] <- 2}
+      (return #f))
+
+  {c <- (first L)}
+
+  (if {c = t} then ;; c is the solution
+      {dyna[ls t] <- 1}
+      (return #t))
+
+  {R <- (rest L)} ;; continue searching a solution in the rest
+
+  (if {c > t}  then ;; c is to big to be a solution
+      {s <- (subset-sum-dynamic-new-syntax R t)}
+   else
+      ;; c is part of the solution or c is not part of solution
+      {s <- (subset-sum-dynamic-new-syntax R {t - c}) or (subset-sum-dynamic-new-syntax R t)})
+
+  {dyna[ls t] <- (tf->12 s)}
+  s) ;; return boolean value
+
+
 ;;(subset-sum-condx L-init t-init)
 ;;$1 = #t