Заметки на breys.ru

О языке программирования Scheme. Часть вторая.

k0rvin@jabber.ru ( korvin ) — Tue, 31 Mar 2009 09:14:07 +0400

1. И так, посмотрим, что можно сделать с помощью замыканий. В стандарт ANSI Common Lisp включена Common Lisp Objective System, реализующая полноценная ООП система. Станадрт же Scheme (R5RS как я понимаю текущий) описан значительно более меньший функционал, который должен быть реализован в интерпретаторе/компиляторе Схемы и поддержка ООП в нем не декларирована. Но поскольку считается, что Лисп позволяет реализовать любую парадигму программирования без измененния базового интерпретатора/компилятора, попробуем реализовать простую ООП систему с помощью замыканий.

;(module object)  ;;; required by bigloo

;(require-extension syntax-case)  ;;; required by chicken

(define-syntax define-object
  (syntax-rules (:)
    ((_ name : class)
     (define name (class 'name 'class)))))

(define (error-class name class)
  (let* ((name name)
	 (class class)
	 (errors (list 'type-mismatch 'unknown-action))
	 (actions (list 'get-errors 'get-actions 'msg))
	 (msg (lambda (args)
		(for-each display args)
		(newline)))
	 (error (lambda args 
		  (msg (cons "* ERROR: " (cons name (cons ": " args)))))))
    (lambda (action . value)
      (cond ;-- GET-actions:
	((eq? action 'get-errors) errors)
	((eq? action 'get-actions) actions)
	;-- OTHER-actions:
	((eq? action 'msg) (msg value))
	;-- ERROR-actions:
	((eq? action 'type-mismatch)
	 (if (pair? value)
	     (error "wrong type of `" (car value) 
		    "' must be " (cadr value))
	     (error "not enough parameters in 'type-mismatch message")))
	(else (error "unknown action `" action "'") 
	      'unknown-action)))))

(define (base-class name class)
  (let ((name name)
	(class class)
	(error (error-class name class))
	(actions (list 'get-name 'get-class 'msg 'get-actions)))
    (lambda (action . value)
      (cond ;-- GET-actions:
	((eq? action 'get-name) name)
	((eq? action 'get-class) class)
	((eq? action 'get-actions) (cons actions (error 'get-actions)))
	;-- OTHER-actions:
	(else (apply error (cons action value)))))))

(define (parent-class name class)
  (let ((name name)
	(class class)
	(parent (base-class name class))
	(actions (list 'get-int-field 'set-int-field))
	(int-field 0))
    (lambda (action . value)
      (cond ;-- GET-actions:
	((eq? action 'get-int-field) int-field)
	((eq? action 'get-actions) (cons actions (parent 'get-actions)))
	;-- SET-actions:
	((eq? action 'set-int-field)
	 (if (integer? (car value))
	     (set! int-field (car value))
	     (parent 'type-mismatch 'int-field 'integer)))
	;-- OTHER-actions:
	(else (apply parent (cons action value)))))))

(define (child-class name class)
  (let ((name name)
	(class class)
	(parent-obj (parent-class name class))
	(base-obj (base-class name class))
	(actions (list 'get-str-field 'set-str-field))
	(str-field ""))
    (lambda (action . value)
      (cond ;-- GET-actions:
	((eq? action 'get-str-field) str-field)
	((eq? action 'get-actions)
	 (cons actions (parent-obj 'get-actions)))
	;-- SET-actions:
	((eq? action 'set-str-field)
	 (if (string? (car value))
	     (set! str-field (car value))
	     (parent-obj 'type-mismatch 'str-field 'string)))
	;-- OTHER-actions:
	(else (apply parent-obj (cons action value)))))))

;-- TESTING:

(define-object base-obj   : base-class)
(define-object parent-obj : parent-class)
(define-object child-obj  : child-class)

(define (test-base-obj)
  (let ((obj base-obj))
    (obj 'msg "  ---- base-obj ----"
              "\nclass   : " (obj 'get-class)
	      "\nname    : " (obj 'get-name)
              "\nactions : " (obj 'get-actions)
              "\nerrors  : " (obj 'get-errors))
    (newline)
    (obj 'action)
    (newline)))

(define (test-parent-obj)
  (let ((obj parent-obj))
    (obj 'msg "  ---- parent-obj ----"
              "\nclass     : " (obj 'get-class)
	      "\nname      : " (obj 'get-name)
	      "\nactions   : " (obj 'get-actions)
              "\nerrors    : " (obj 'get-errors)
              "\nint-field : " (obj 'get-int-field))
    (newline)
    (obj 'set-int-field 12)
    (obj 'set-int-field "df")
    (obj 'msg "\nint-field : " (obj 'get-int-field))
    (newline)))

(define (test-child-obj)
  (let ((obj child-obj))
    (obj 'msg "  ---- child-obj ----"
              "\nclass     : " (obj 'get-class)
	      "\nname      : " (obj 'get-name)
              "\nactions   : " (obj 'get-actions)
	      "\nerrors    : " (obj 'get-errors)
              "\nstr-field : " (obj 'get-str-field) 
	      "\nint-field : " (obj 'get-int-field))
    (newline)
    (obj 'set-str-field "abc")
    (obj 'set-int-field 5)
    (obj 'some-action)
    (obj 'set-str-field 'abc)
    (obj 'msg "\nstr-field : " (obj 'get-str-field) 
	      "\nint-field : " (obj 'get-int-field))
    (newline)))

(test-base-obj)
(test-parent-obj)
(test-child-obj)

Как видно из кода система получилась в стиле "передачи сообщений объекту", где в качестве "объектов" выступают функции-замыкания, сохраняющие свое состояние(поля) а в качестве "классов" -- функции высшего порядка, возвращающие(создающие) "объекты".

2. Как известно Лисп превосходно подходит для реализации языков, например всяких DSL/eDSL. Говорят что на Лиспе Вы не описываете как решить задачу, а подгоняете язык под задачу до тех пор, пока не создадите язык, на котором задача формулируется легко и просто. Приведу несколько пример, как можно расширить синтаксис/семантику Scheme.

2.1. Один мой знакомый очень любит язык Pascal. Специально для него вот немного сахарку в Схему, предоставляющую пару паскалеподобных конструкций:

(define-syntax for
  (syntax-rules (:= to do)
    ((_ i := a to n do e ...)
     (if (< a n)
         (let ((i a) 
	       (f (lambda (i f)
		    (if (<= i n)
		        (begin
			  e ...
			  (f (+ i 1) f))))))
	   (f i f))))))

(define-syntax while
  (syntax-rules (do)
    ((_ s do e ...)
     (let ((f (lambda (f)
		(if s
		    (begin
		      e ...
		      (f f))))))
       (f f)))))

(define-syntax repeat
  (syntax-rules (until)
    ((_ (e ...) until s)
     (let ((f (lambda (f)
		(begin
		  e ...
		  (if s (f f))))))
       (f f)))))

(define integer integer?)
(define real    real?)
(define char    char?)
(define TString string?)
(define TVector vector?)
(define TPair   pair?)
(define TList   list?)

(define-syntax function
  (syntax-rules (:)
    ((_ name ((a1 : t1) (a2 : t2) ...) : type 
	(e1 e2 ...))
     (define (name a1 a2 ...)
       (let 
	 ((result
	    (if (and (t1 a1) (t2 a2) ...)
	        (begin e1 e2 ...)
		(begin
	          (message "* ERROR: type mismatch in function ``(" 'name 
			   " " '((a1 : t1) (a2 : t2) ...) 
		           " : " 'type ")'':\n         (" 'name 
			   " " `,(list a1 a2 ...) ")")
		  'null))))
	 (if (type result)
	     result
	     (if (eq? result 'null)
	         (message "         function returns `null'")
	         (message "* ERROR: wrong result type in function ``(" 'name
			  " " '((a1 : t1) (a2 : t2) ...)
			  " : " 'type ")'':\n         (" 'name
			  " " `,(list a1 a2 ...) ") -> " result))))))))

(define-syntax procedure
  (syntax-rules (:)
    ((_ name ((a1 : t1) (a2 : t2) ...) 
	(e1 e2 ...))
     (define (name a1 a2 ...)
       (if (and (t1 a1) (t2 a2) ...)
	   (begin
	     (begin e1 e2 ...)
	     'null)
	   (message "* ERROR: type mismatch in procedure (" 'name 
		    " "  '((a1 : t1) (a2 : t2) ...) 
		    "):\n         (" 'name " " `,(list a1 a2 ...) ")"))))))

(define-syntax [
  (syntax-rules (.. ])
    ((_ x0 .. xN ])
     (let* ((dx (if (< x0 xN) 1 -1)) 
	    (f (lambda (x f)
		 (if (= x xN)
		     (cons x '())
		     (cons x (f (+ x dx) f))))))
       (f x0 f)))
    ((_ x0 x1 .. xN ])
     (let* ((dx (- x1 x0))
	    (f (lambda (x f)
		 (if (> x xN)
		     '()
		     (cons x (f (+ x dx) f))))))
       (f x0 f)))))

(message ([ 1 .. 20 ]))
(message ([ 1 3 .. 20 ]))
(message (apply + ([ 1 3 .. 20 ])))

;------------------------------

(function summ-func ((a : integer) (b : integer)) : integer 
    (  ;begin
	(+ a b)
    )) ;end

(message (summ-func 1 2))
(message (summ-func 1 2.0))
(message (summ-func 1 2.1))

(function summ-func-2 ((a : integer) (b : integer)) : integer
    (  ;begin
	(cons a b)
    )) ;end

(message (summ-func-2 1 2))

(procedure summ-proc ((a : integer) (b : integer)) 
    (  ;begin
	(display (+ a b))
	(newline)
    )) ;end

(summ-proc 1 2)
(summ-proc 1 2.0)
(summ-proc 1 2.1)

;------------------------------

(display "for i in [1..10] do : ")

(for i := 1 to 10 do
  (display i)
  (display " "))

(newline)

(display "while  i  <  10  do : ")

(define x 0)

(while (< x 10) do
  (display x)
  (display " ")
  (set! x (+ x 1)))

(newline)

(display "repeat until x < 10 : ")

(set! x 0)

(repeat 
  ((display x)
   (display " ")
   (set! x (+ x 1)))
  until (< x 10))

(newline)

2.2. А вот пример реализации простейшей базы данных и sql-еподобных языковых конструкций для работы с ней(здесь был использован опыт из пункта 1 про ООП)

(define *current-db* '())

(define number  (cons 'number number?))
(define char    (cons 'char char?))
(define varchar (cons 'varchar string?))
(define bool    (cons 'bool boolean?))
(define int     (cons 'int integer?))
(define symbol  (cons 'symbol symbol?))

(define (make-field name type default-value)
  (let ((name   name)
	(type   type)
	(defval default-value)
	(vals '()))
    (lambda (action . args)
      (cond
	((eq? action 'get-name) name)
	((eq? action 'get-values) vals)
	((eq? action 'get-type) (car type))
	((eq? action 'get-value)
	 (if (not (null? args))
	   (if (integer? (car args))
	       (let find-val ((ls vals)
			      (n (car args)))
		 (if (null? ls)
		     '()
		     (if (= n 0)
			 (car ls)
			 (find-val (cdr ls) (- n 1))))))
	   '()))
	((eq? action 'set-value)
	 (if (not (null? args))
	   (if ((cdr type) (car args))
	     (if (not (null? (cdr args)))
	       (if (integer? (cadr args))
	           (set! vals (set-ref vals (car args) (cadr args))))))))
	((eq? action 'add-value)
	 (if (not (null? args))
	   (if ((cdr type) (car args))
	       (set! vals (append vals (list (car args)))))
	   (set! vals (append vals (list defval)))))))))

(define (make-db name)
  (let ((name name)
	(tables '()))
    (lambda (action . args)
      (cond ((eq? action 'add-table)
	     (set! tables (cons args tables)))
	    ((eq? action 'get-tables)
	     (if (not (null? tables))
		 (map car tables)))
	     ;tables)
	    (else
	      (if (symbol? action)
		  (let 
		    ((result (let find-table ((table action)
					      (tables tables))
			       (if (null? tables)
				   'null
				   (if (eq? table (caar tables))
				       (cadar tables)
				       (find-table table (cdr tables)))))))
		    (if (eq? result 'null)
			(lambda args
			  (message "*ERROR* " name ": no tables with name `" action "' found\n"))
			result))
		  (message "*ERROR* " name ": wrong type of action")))))))

(define (make-table name columns)
  (let ((name name)
	(columns columns))
    (lambda (action . args)
      (cond 
	((eq? action 'get-name) name)
	((eq? action 'get-columns) 
	 (map (lambda (col) 
		(cons (col 'get-name) (col 'get-values)))
	      columns))
	((eq? action 'select-column)
	 (if (not (null? args))
	   (if (symbol? (car args))
	       (let find-cols ((cols columns))
		 (cond
		   ((null? cols) 'null)
		   ((eq? ((car cols) 'get-name) 
			 (car args))
		    (cons ((car cols) 'get-name) 
			  ((car cols) 'get-values)))
		   (else (find-cols (cdr cols))))))))
	((eq? action 'append-record)
	 (let add-values ((cols columns)
			  (vals args))
	   (if (not (null? cols))
	       (if (null? vals)
		   (begin
		     ((car cols) 'add-value ((car cols))
		     (add-values (cdr cols) '())))
		   (begin
		     ((car cols) 'add-value (car vals))
		     (add-values (cdr cols) (cdr vals)))))))))))


(define-syntax use
  (syntax-rules ()
    ((_ db)
     (set! *current-db* db))))

(define-syntax create
  (syntax-rules (field : table database)
    ((_ field name : type (default-value))
     (define name (make-field 'name type default-value)))
    ((_ table name ((f t v) ...))
     (let ((table (make-table 'name 
		    (list (make-field 'f t v)
			  ...))))
       (*current-db* 'add-table (table 'get-name) table)))
    ((_ database name)
     (define name (make-db 'name)))))

(define-syntax insert
  (syntax-rules (into values:)
    ((_ into table values: v ...)
     ((*current-db* 'table) 'append-record v ...))))

(define print 
  (lambda (ls)
    ;(message ls)
    (if (pair? ls)
      (if (not (null? (car ls)))
        (begin
	  (for-each (lambda (x) 
		      (display x) 
		      (display "\t"))
		    (map car ls))
	  (display "\n")
	  (print (map cdr ls)))))))

(define-syntax select
  (syntax-rules (* from)
    ((_ * from table)
     (print ((*current-db* 'table) 'get-columns)))
    ((_ (field ...) from table)
     (print (list ((*current-db* 'table) 'select-column 'field)
		  ...)))
    ((_ ((f1 ...) ...) (from t1 ...))
     (begin
       (let ((table 't1))
	 (message ((*current-db* table) 'get-name) ": ")
         (print (list ((*current-db* table) 'select-column 'f1)
		      ...))
	 (newline))
       ...))))

;------------------------------------------------------

(define-syntax test
  (syntax-rules ()
    ((_ (f ...))
     (begin
       (message ";;; " '(f ...) ": ")
       (f ...)))
    ((_ displayfunc (f ...))
     (begin
       (message ";;; " '(f ...) ": ")
       (displayfunc (f ...))))))

;------------------------------------------------------

(define main-test
  (lambda ()
    (create database test-db)
    (create database other-db)

    (use test-db)

    (create table table-1 ((name varchar "")
			   (age  int      0)
			   (sex  symbol 'male)))

    (create table table-2 ((name varchar "")
			   (age  int      0)
			   (sex  symbol 'male)
			   (prof varchar "")))

    (test message (*current-db* 'get-tables))
    (test message ((test-db 'table-1) 'get-columns))
    (test message ((test-db 'table-2) 'get-columns))

    (insert into table-1 values: "vasya" 22 'male)
    (insert into table-1 values: "kolya" 24 'male)

    (test message ((*current-db* 'table-1) 'get-columns))
    (test message ((*current-db* 'table-1) 'select-column 'age))

    (test (select (name age) from table-1))
    (test (select * from table-1))

    (insert into table-2 values: "lena" 23 'female "manager")

    (test (select * from table-2))
    (test (select ((name age) (name sex prof)) (from table-1 table-2)))
    (test (select * from table-2))

    (use other-db)

    (test (select * from table-2))

    (create table table-3 ((id     int      0) 
			   (name   varchar "") 
			   (f_name varchar "")
			   (dep_id int      0)))

    (test (select * from table-3))

    (insert into table-3 values: 1 "name" "family name" 2)

    (test (select * from table-3))

    (use test-db)))


(define field-object-test
  (lambda ()
    (create field age : int (0))
    
    (test message (age 'get-name))
    (test message (age 'get-values))
    (test message (age 'get-value))
    (test message (age 'get-value 2))
    
    (age 'add-value 23)
    
    (test message (age 'get-value 0))
    (test message (age 'get-values))
    
    (age 'set-value 25 0)
    
    (test message (age 'get-values))))

;(field-object-test)

(main-test)

2.3. А теперь попробуем реализовать свой язык, например нечто похожее на Форт, ибо он, пожалуй, еще проще Лиспа:

(define ~ `~)
(define begin-declare `[)
(define delim-declare `|)
(define end-declare   `])
(define if-expr   `if)
(define else-expr `else)
(define then-expr `then)
(define assign `>>)
(define norm-recursion 'normal)
(define tail-recursion 'tail)

(define basic-dictionary
  (list
   `(+  ~ ,(list +))
   `(-  ~ ,(list -))
   `(*  ~ ,(list *))
   `(/  ~ ,(list /))
   `(>  ~ ,(list >))
   `(<  ~ ,(list <))
   `(^  ~ ,(list (lambda args (cdr args))))
   `(&  ~ ,(list (lambda args (car args))))
   `(*> ~ ,(list (lambda args (apply printf args) '())))
   `(@> ~ ,(list (lambda args (apply printl args) '())))
   `(true  ~ ,(list #t))
   `(false ~ ,(list #f))
   `(null? ~ ,(list (lambda args (null? args))))
  ))

(define eof-error "unexpected EOF")
(define syntax-error "wrong syntax")


(define (declare name text)

  (define (make-body params body text braces)
    (cond

      ((null? text)
       (error declare "`" name "': " eof-error))

      ((eq? (car text) begin-declare)
       (make-body
	 params
	 (cons (car text) body)
	 (cdr text)
	 (+ braces 1)))

      ((eq? (car text) end-declare)
       (if (= 0 braces)
	   (list
	     (list
	       name
	       params
	       (reverse body))
	     (cdr text))
	   (make-body
	     params
	     (cons (car text) body)
	     (cdr text)
	     (- braces 1))))
      (else
	(make-body
	  params
	  (cons (car text) body)
	  (cdr text)
	  braces))))

  (define (make-head params text)
    (cond

      ((null? text)
       (error declare "`" name "': " eof-error))

      ((or (eq? (car text) begin-declare)
	   (eq? (car text) end-declare)
	   (not (symbol? (car text))))
       (error declare "`" name "': " syntax-error))

      ((eq? (car text) delim-declare)
       (make-body
	 (if (null? params) ~ params)
	 '()
	 (cdr text)
	 0))

      (else
	(make-head
	  (cons (car text) params)
	  (cdr text)))))

  (make-head '() text))


(define (make-then-else text)

  (define (make-t-e then-text else-text text)
    (cond

      ((null? text)
       (error make-then-else eof-error))

      ((eq? (car text) else-expr)
       (make-t-e 
	 '() 
	 then-text 
	 (cdr text)))

      ((eq? (car text) then-expr)
       (list
	 (reverse then-text)
	 (reverse else-text)
	 (cdr text)))

      (else
	(make-t-e
	  (cons (car text) then-text)
	  else-text
	  (cdr text)))))

  (make-t-e '() '() text))


(define (make-env stack word)

  (define (make-e stack params env)
    (cond

      ((null? params)
       (list env stack))

      ((null? stack)
       (error make-env eof-error))

      (else
	(make-e
	  (cdr stack)
	  (cdr params)
	  (cons
	    (list (car params) ~ (list (car stack)))
	    env)))))

  (make-e stack word '()))


(define (redeclare word words)
  (define (make-words word head tail)
    (cond
      ((null? tail)
       (reverse head))
      ((eq? (car word) (caar tail))
       (append
	 (reverse head)
	 (cons word (cdr tail))))
      (else
        (make-words
	  word
	  (cons (car tail) head)
	  (cdr tail)))))
  (make-words word '() words))


(define (*iter* stack text words env recursion-type)
  ;(printl (length words) (length env))
  ;(printl (length stack) (length text))
  ;(printl words)
  ;(printl env)
  (cond

    ((null? text) stack)
    
    ((or (number?  (car text))
	 (boolean? (car text))
	 (char?    (car text))
	 (string?  (car text)))
     (*iter*
       (cons (car text) stack)
       (cdr text)
       words
       env
       recursion-type))
    
    ((symbol? (car text))
     (let ((sym (car text)))
       (cond

	 ((eq? sym begin-declare)
	  (let ((word/text 
		  (declare (cadr text) (cddr text))))
	    (*iter*
	      stack
	      (cadr word/text)
	      (if (eq? recursion-type norm-recursion)
		  (cons (car word/text) words)
		  (redeclare (car word/text) words))
	      env
	      recursion-type)))

	 ((eq? sym if-expr)
	  (let ((condition (car stack)) 
		(then/else/text
		  (make-then-else (cdr text))))
	    (if condition
	        (*iter*
		  (cdr stack)
		  (append (car   then/else/text)
			  (caddr then/else/text))
		  words
		  env
		  recursion-type)
	        (*iter*
		  (cdr stack)
		  (append (cadr  then/else/text)
			  (caddr then/else/text))
		  words
		  env
		  recursion-type))))

	 ((eq? sym assign)
	  (*iter*
	    '()
	    (cddr text)
	    (cons (list (cadr text) ~ stack)
		  words)
	    env
	    recursion-type))

	 (else
	   (let ((word
		   (cond 
		     ((assoc sym env) => (lambda (x) x))
		     ((assoc sym words) => (lambda (x) x))
		     (else
		       (begin
		         (error *iter* "word `" sym 
				"' not found in dictionary")
			 (list printl))))))
	     (cond

	       ((eq? (cadr word) ~)
		(*iter*
		  stack
		  (append (caddr word) (cdr text))
		  words
		  env
		  recursion-type))

	       ((null? (cdr text))
		(let ((env/stack
			(make-env stack (cadr word))))
		  (*iter*
		    (cadr env/stack)
		    (append (caddr word) (cdr text))
		    words
		    (car env/stack)
		    tail-recursion)))

	       (else
		 (let ((env/stack
			 (make-env stack (cadr word))))
		   (*iter*
		     (cadr env/stack)
		     (append
		       (*iter*
			 '()
			 (caddr word)
			 (append env words)
			 (car env/stack)
			 norm-recursion)
		       (cdr text))
		     words
		     env
		     recursion-type)))))))))

    (else
      (let ((result
	      (apply
		(car text)
		(reverse stack))))
	(*iter*
	  '()
	  (if (null? result)
	      (cdr text)
	      ((if (pair? result) append cons) result (cdr text)))
	  words
	  env
	  recursion-type)))))


(define (run ls)
  (*iter* '() ls basic-dictionary '() norm-recursion))

(define (interpretator)
  (let 
    ((result
     (run `(
      1 2 7 + 5 6 -	    ; (1 +2 +7) -5 -6 = 10 -5 -6 = -1 ; stack: < -1 ]
      
      [ a | 5 + ]	    ; let a = f(ls) = (ls 5 +)
      [ x | 5 ]		    ; let x = 5
			    ; stack: < -2 -1 ]
      -2 a		    ; a(-2 -1) = -2 -1 +5 = 2 ; stack: < 2 ]
      
      [ square x | x x * ]  ; let square = f(x) = x * x
                            ; stack: < 2 2 ]
      2 square	            ; square(2) = 2 * 2 = 4 ; stack: < 4 2 ]
      
      [ quad x |            ; let quad = f(x) =
	x square square ]   ;   square( square(x) )

      quad		    ; quad(4) = square( square(4) ) = square(16) = 256 
			    ; stack < 256 2 ]
      x	a		    ; stack < 5 256 2 ]
                            ; a(5 256 2) = +5 +256 +2 +5 = 268 ; stack: < 268 ]
      1500                  ; stack: < 1500 268 ]

      [ b x y |             ; let b = f(x, y) =
	x y > if            ;   if (x > y) then
	  3 quad   else     ;     square(x)
	  x square then ]   ;   else quad(3)

      b                     ; b( 268, 1500 ) ; stack: < 81 ]
      >> xx                 ; let xx = 81
      xx null? if           ; if (xx == null) then
	xx ^ else           ;   0
	0    then           ; else cdr(xx) ; stack: < ]
      xx @>                 ; printl(xx) = printl( 81 )
      
      [ yy | 123 ]          ; let yy = 123 ; -- "global" yy
      [ def x |             ; let def = f(x) =
	x xx > if           ;   if (x > xx) then
	  [ yy | xx ] else  ;     let yy = x     ; "local" yy
	  [ yy | x  ] then  ;   else let yy = xx ; "local" yy
	yy @> ]             ;   printl(yy)
      
      80 def                ; def(80) = (80 > 81)? = false => let yy = xx = 81 => printl(81)
      82 def                ; def(82) = (82 > 81)? = true => let yy = x = 82 => print(82)
      yy @> @>              ; printl(yy) = print(123) ; "global" yy
      
      [ n? |
	null? if
	  1 else
	  0 then ]
      
      n? 2 n? @>

      [ abs x |
	x 0 < if
	  x      else
	  x -1 * then ]
      
      2 abs -2 abs @> @>
      
      [ fac n |
	n 2 < if
	  n 1 - fac n * else
	  1 then ]
      
      "recursive factorial: " @>
      "34 ! = " *> 34 fac @>
      @>

      [ mul x y | x y * ]

      [ test x |
	x "! = " *> 
	x fac-i @> ]

      [ fac-i n |
	[ f-iter n acc |
	  2 n > if
	    n 1 - acc n mul f-iter 
	  else
	    acc 
	  then ]
	n 1 f-iter ]
      
      "iterative factorial: " @>
      12 test

      [ add x y | x y + ]

      [ cycle x y |
	[ abc | 2 ]
	0 x < if
	    y *> x y 1 add cycle 
	  then ]
      
      1 1 cycle
     ))))
    (display "done: stack: ")
    (if (null? result)
	(display "()")
	(apply printf result))
    (newline)))

(interpretator)

Как видно из кода на вновьпридуманном "форте" в его интерпретаторе реализована оптимизация хвостовой рекурсии, в конце приведена проверка этого утверждения -- функция [ cycle x y | ... ] . Я на своем EeePC 1000HD оборвал цикл на 1144131-й итерации, ибо надоело ждать (на работу цикла ушло ~ 5 -- 10 минут). Если кто захочет проверить, отпишитесь о результатах, на какой итерации остановились или был Stack overflow. =) Тем не менее факториал 12345 функция fac-i считает запросто =)

На сегодня все.

UPD: я совсем забыл про словарь words, он разрастался при любом типе рекурсии, но я это исправил и поправил соответствующим образом код в статье

О языке программирования Scheme

k0rvin@jabber.ru ( korvin ) — Thu, 26 Feb 2009 15:52:24 +0400

0. Небольшое вступление.

Данная заметка посвящена языку программирования(ЯП) Scheme.

В сети достаточно информации по этому ЯП, например весьма неплохое руководство http://www.scheme.com/tspl2d
(часть описанных мною примеров взяты частично или полностью из этого руководства), кроме того при желании можно найти небезызвестную книгу "Structure and Implementation of Computer Programs" (SICP), являющуюся одной из лучших книг по программированию вообще и по Scheme в частности. Поэтому целью данной заметки является не очередное "пересказывание" этих трудов, а скорее попытка объяснить Scheme, его особенности, возможности так сказать "на пальцах". В частности я буду описывать, что сам уже смог понять, узнать о Scheme и программировании.

Scheme как и Lisp является мультипарадигменным языком программирования "почти без синтаксиса", разработанный в Массачуссетском Институте Технологий. Некоторые называют Scheme языком функционального программирования(ФП), приравнивая таким образом его к чисто функциональным языкам на подобии Haskell, однако, несмотря на то, что Scheme позволяет писать код в стиле ФП, такое приравнивание некорректно. Более точное и подробное описание языка вы можете найти в Википедии, там же найдете и еще некоторые полезные ссылки.

Поскольку до написания этой заметки я уже оставил несколько подобных на паре форумов в сети, то эта, первая, заметка в данном блоге будет относительно более длинной, чем последующие и состоять из вышеупомянутых заметках на форумах.

1. Немного о "почти отсутствующем синтаксисе".

В отличие от более распространенных и привычных ЯП, таких как C, C++, Pascal, Java, PHP и т. д., в Scheme и Lisp используется префиксная запись функций и операторов, а также огромное количество скобок, что может отпугнуть новичков от изучения языка, однако чем дальше вы зайдете в изучении Scheme, тем больше вы будете понимать, что это очень удобная форма записи, открывающая большие возможности для манипулирования кодом и данными. Впрочем не исключен эффект еще большего отторжения =). В этом случае взгляните на Forth, где используется польская, постфиксная нотация, она вам покажется еще более непривычной, и отталкивающей =).

Итак, вот несколько примеров программ на Scheme:

(* 1 2 3 4 5) ; Произведение чисел от 1 до 5

(define (square x) ; Объявление функции возведения в квадрат как
(* x x))          ;   произведение аргумента на самого себя

(define (abs x) ; Объявление функции модуля:
(if (< x 0)    ;   особая форма if вычисляет первый аргумент (функцию <, сравнивающую значение аргумента x с нулем) и
      (- x)      ;     возвращает результат вычисления второго аргумента, если первый вернул #t (истину) или
      x))        ;     третьего в противном случае

Как видно из примера, синтаксис действительно очень регулярен и почти отсутсвует, любая функция имеет следующую форму вызова:

(funcname arg1 arg2 arg3 ... argN)

называемой S-выражением. Границами формы служат круглые скобки, а разделителями имен -- пустое пространство(символы пробела, табуляции и новой строки). Первый символ интерпретируется как вызов функции с ним связанной, для остальных вычисляются значения, с ними связанные, при чем нет никакой разницы, что является значением -- функция или, например, числовая константа, поэтому передача функций как параметров другим функциям является простой и не портит синтаксиса, например:

(define (is func) ; Объявление функции is от func как
(lambda (a b) (func a b))) ; возвращающую функцию от a, b, вычисляющую функцию func от a, b
(define greater? (is >))
(let ((x 1) (y 2))
(greater? x y))

Исключениями являются только особые формы (в данном примере это define и if), которые определяются макросами и тем не менее незначительно отличаются от формы вызова функции. Символ ; означает начало комментария, весь текст, находящийся за ним и до конца строка игнорируется интерпретатором.
Вот и почти весь синтаксис. Некоторые другие "знаки препинания", отличающиеся от вышеуказанной формы синтаксиса и являющиеся в большинстве своем "синтаксическим сахаром" мы рассмотрим позже, по мере необходимости.

2. Немного о списках.

Основной структурой данных в Scheme, как и в Lisp, является список. Основные функции работы со списками:

(cons 1 2)                      ; возвращает пару значений: (1 . 2)
(cons 1 '())                    ; возвращает список из одного элемента: (1)
(list 1 2 3)                    ; Возвращает список значений: (1 2 3)
(cons 1 (cons 2 (cons 3 '()))) ; возвращает список значений: (1 2 3)
(car (list 1 2 3))              ; возвращает значение первого элемента(головы) списка (1 2 3): 1
(cdr (list 1 2 3))              ; возвращает список, начинающийся со второго элемента(хвост) списка (1 2 3): (2 3)

Конструкция '() обозначает пустой список, символ ' же обозначает цитирование и является синтаксическим сахаром для особой формы (quote ...). Например вызов функции

(list 1 2 3) ; можно заменить на конструкцию:
'(1 2 3)

Однако не стоит их путать, в отношении констант-значений типа цифр, чисел, строк, заключенных в двойные ковычки, оба выражения равноправны, однако по отношению к символам, связанным с каким-либо значением, дают разный результат, например:

(let ((x 1) (y 2) (z 3))   ; Пусть x = 1, y = 2, z = 3, тогда:
(list x y z))            ;   вернет список значений переменных x, y и z: (1 2 3)
(let ((x 1) (y 2) (z 3))
'(x y z))                ; вернет список символов x y и z: (x y z)

3. О макросах.

Макросы позволяют создавать новые особые формы, расширяя тем самым синтаксис языка. Например:

(define-syntax my-if           ; Объявляем имя синтаксической конструкции
(syntax-rules (then else)    ; описываем правила: в первом списке -- (then else) --
                               ;   перечисляем слова, которые будут невычисляемыми, а ля "зарезервированные слова"
                               ; в последующих списках описываются шаблоны, которые будет обрабатывать макросом
                               ;   и собственно обработчики:

    ((_ condition then on-true else on-false) ; здесь описываем шаблон конструкции: _ -- сюда подставляется имя макроса,
                               ;   можно написать my-if вместо _ , без разницы
                               ;   then и else как мы описали раньше просто слово,
                               ;   condition, on-true и on-false -- так сказать локальные переменные макроса,
                               ;   выражения, переданные в них -- вычисляемые
    (if condition on-true on-false)) ; а это обработчик шаблона. шаблонов может быть несколько, например можно добавить еще 2:
    ((_ condition then on-true)
    (if condition on-true))
    ((_ condition else on-false)
    (if (not condition) on-false))
))                             ; здесь закрываем списки особых форм syntax-rules и define-syntax.

; теперь мы можем пользоваться придуманным макросом:
(my-if (> 2 4) then (display "Y\n") else (display "N\n"))
(my-if (> 4 2) then (display "Y\n"))
(my-if (> 4 2) else (display "Y\n"))

Воспользоваться просто определением функции здесь не удалось бы, так как значения аргументов функции вычисляются перед передачей в функцию, т. е. у нас бы в любом случае программа выполнила бы операторы обоих веток, независимо от значения аргумента-условия и чтобы избежать этого, нам пришлось бы каждый раз явно передавать аргументы-ветки через функцию (delay ...) , откладывающую вычисление своего аргумента.

Еще один пример, показывающий реализацию операторов i++, i--, x += y, x -= y, x *= y и x /= y, содержащий в том числе и элементы метапрограммирования: макрос make-op сам создает для нас макросы, определяющие четыре последних оператора:

(define-syntax make
(syntax-rules ()
    ((_ op func)
    (define-syntax op
       (syntax-rules ()
    ((_ x y)
    (begin (set! x (func x y)) x)))))))

(make += +)
(make -= -)
(make *= *)
(make /= /)

(define-syntax ++
(syntax-rules ()
    ((_ i)
    (begin (set! i (+ i 1)) i))))

(define-syntax --
(syntax-rules ()
    ((_ i)
    (begin (set! i (- i 1)) i))))

;--------------------------------
; Пробуем работу:

(define x1 2)
(define x2 3)
(message "x1 = " x1 "; x2 = " x2)
(++ x1)
(+= x2 (-- x2))
(message "x1 = " x1 "; x2 = " x2)
(+= x1 x2) (message "x1 = " x1)
(*= x1 x2) (message "x1 = " x1)
(-= x1 x2) (message "x1 = " x1)
(/= x1 x2) (message "x1 = " x1)

4. О карринге, замыканиях и функциях высшего порядка.

Теперь примерчик с каррингом (приведение функции n аргументов к функции одного аргумента, возвращающей функцию n-1 аргументов) и функций высшего порядка (функции, оперирующие другими функциями):

(define (make-val-list v0 dv vN)
(define (make-list v)
    (if (= v vN)
    (cons v '())
    (cons v (make-list (+ v dv)))))
(make-list v0))

(define A-list (make-val-list 1 1 3))
(define x-list (make-val-list 0.2 0.1 1.2))

(define (y A)
(lambda (x) (- (* A x) (tan (* pi (/ x 4))))))

(define y-list (map (lambda (A)
            (map (y A) x-list))
            A-list))

(display (map (lambda (ls) (apply max ls)) y-list))

В данном коде функция-от(x,A) сведена к функции y(A), возвращающей функцию-от(х), т.е. ее можно было бы применять так:

(let ((A1 1) (x1 0.2))
((y A1) x1))

Карринг очень похож на замыкание как я понял, только замыкание проявляется в следующих действиях:

(define y1 (y 1)) ; создаст функцию (y1 x) = (- (* 1 x) (tan (* pi (/ x 4))))
(define y2 (y 2)) ; создаст функцию (y1 x) = (- (* 2 x) (tan (* pi (/ x 4))))
(y1 x1)
(y2 x1)

В примере применялись функции высшего порядка map и apply, они работают следующим образом:

1) map применяет переданую ей в качестве переданного аргумента функцию к каждому элементу списка, переданного вторым аргументом, и возвращает список значений-результаттов применения, например

(define test-list '(-2 1 7 0 -5 4))
(map abs test-list)                  ; вернет список абсолютных величин значений списка test-list: (2 1 7 0 5 4)

2) apply применяет переданную ей в качестве первого аргумента функцию ко всем элементам списка, переданного вторым аргументом,
как буд-то они (элементы списка) являются параметрами переданной функции, например функции

(max -2 1 7 0 -5 4) ; \
(+ -2 1 7 0 -5 4)    ; _вернут максимальное значение и сумму значений переданных в качестве параметров соответственно.

однако попытка вызвать их таким образом:

(max test-list)      : \
(+ test-list)        ; _выдаст ошибку.

Это не очень удобно, когда, например, в ходе работы программы генерируется некий список значений, из которого потом нужно выбрать максимальное значение, или сумму подсчитать. Тут-то и приходит на помощь функция apply, которая как-бы раскрывает список, т. е. выражения

(apply max test-list) ; \
(apply + test-list)    ; _эквивалентны выражениям
(max -2 1 7 0 -5 4)    ; \
(+ -2 1 7 0 -5 4)      ; _соответственно.

И в завершении вернемся к каррингу. Как видно из описания функции map, она может оперировать только функциями одной переменной. Вот тут-то к нам и приходят на помощь карринг и замыкания =).

5. Немного о функциях и макросах с произвольным количеством аргументов.

Как вы уже заметили, некоторые функции и формы могут принимать произвольное количество аргументов, например:

(+ 1 2 3)
(+ 1 2 3 4)
(and exp1 exp2)
(and exp1 exp2 exp3 exp4)

Чтобы создать подобную функцию, необходимо использовать точечную запись аргументов, например:

(define (message head . tail)
(display head)
(for-each display tail)
(newline))

В таком определении функции первый аргумент будет передаваться в нее непосредственно, параметром head, а все остальные -- списком tail. Здесь используется еще одна функция высшего порядка for-each, которая применяет функцию, переданную в качестве первого аргумента к каждому элементу списка, переданного вторым аргументом, но в отличие от функции map не возвращает никакого значения. теперь можно так применять функцию message:

(message "Hello World!")
(let ((world "World"))
(message "Hello " world "!"))

Определить форму, принимающую произвольное количество аргумента, можно подобным образом:

(define-syntax and
(syntax-rules ()
    ((_) #t)
    ((_ e) e)
    ((_ e1 e2 e3 ...)
    (if e1 (and e2 e3 ...) #f))))

Тогда можно будет использовать новую форму таким образом:

(let ((x     2)
      (x-min 1)
      (x-max 3))
(and (> x x-min)
       (< x x-max)
       (not (= x 0))))

На этом я завершаю свой обзор. Надеюсь он оказался/окажется для кого-то полезным, для кого-то интересным. =)