Предыдущая страница Следующая страница [1] > 2 < [3] [4] [5] [6]

Автор Сообщение

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1000   2009-12-30 23:59 GMT+3 часа(ов)      
;рассматриваются только операторы * / - +
;приоритет: * / - +
(define (op->num op)
(cond ((eq? op *) 4)
((eq? op /) 3)
((eq? op -) 2)
((eq? op +) 1)))
 
(define (num->op n)
(cond ((= n 4) *)
((= n 3) /)
((= n 2) -)
((= n 1) +)))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I. ЭЛЕМЕНТЫ - ЧИСЛА ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;t - список вида (e1 op1 e2 op2 e3 op3 e4)
;get-ops: возвращает список (op1 op2 op3)
(define (get-ops t)
(if (null? (cdr t))
'() ;(cdr '(e4)) => '()
(let ((op (cadr t))
(nt (cddr t)))
(cons op (get-ops nt)))))
 
;ops - список возвращаемый get-ops
;max-op: возвращает оператор с макс приоритетом
(define (max-op ops)
(num->op (apply max (map op->num ops))))
 
(define (i1: . t)
(if (null? (cdr t)) ;(cdr '(res)) => '()
(car t) ;(i1: res) => res
(let* ((ops (get-ops t))
(mop (max-op ops))
(nt (apply-op mop t)))
(apply i1: nt))))
 
(define (apply-op mop t)
(let ((e (car t))
(op (cadr t))
(nt (cddr t)))
(if (eq? op mop)
(cons (op e (car nt)) (cdr nt))
(append (list e op)
(apply-op mop nt)))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; II. ЭЛЕМЕНТЫ - ЧИСЛА И СПИСКИ ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;get-elm: (e1 e2 e3 e4)
(define (get-elm t)
(get-ops (append '(()) t '(()))))
 
;elm - список возвращаемый get-elm
;change: заменяет элементы t на elm
(define (change elm t)
(if (null? (cdr elm))
elm
(let ((e (car elm))
(op (cadr t))
(nelem (cdr elm))
(nt (cddr t)))
(append (list e op)
(change nelem nt)))))
 
(define (i2: t)
(let* ((elm (get-elm t))
(nelm (map (lambda (e)
(cond ((number? e) e)
((list? e) (i2: e))))
elm))
(nt (change nelm t)))
(apply i1:
(map (lambda (x)
(eval x (scheme-report-environment 5)))
nt))))
 
(define-syntax format-infix:
(syntax-rules ()
((_ . t)
(i2: 't))))

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1001   2009-12-31 00:00 GMT+3 часа(ов)      
;test
> (max-op `(,+ ,/ ,- ,- ,+))
#<procedure:/>
 
> (get-ops `(,1 ,+ ,2 ,* ,4 ,- ,2))
(#<procedure:+> #<procedure:*> #<procedure:->)
 
> (apply-op * `(,1 ,+ ,2 ,* ,4 ,- ,2))
(1 #<procedure:+> 8 #<procedure:-> 2)
 
> (i1: 1 + 2 * 4 - 2)
7
 
> (get-elm '((1 + 4) * (8 / 4) - 2))
((1 + 4) (8 / 4) 2)
 
> (change '(5 2 2) '((1 + 4) * (8 / 4) - 2))
(5 * 2 - 2)
 
> (i2: '((1 + 4) * (8 / 4) - 2))
8
 
> (i2: '((1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2)))
-4
 
> (format-infix: (1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2))
-4

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1002   2009-12-31 01:08 GMT+3 часа(ов)      
Но меня не это все интересует! Ты мне объясни, почему нельзя, чтобы
> (2 + 5)
7
Ты сказал, что нельзя, поэтому отвечай за свои слова.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1003   2009-12-31 04:01 GMT+3 часа(ов)      
Ура! Хоть какой-то код с твоей стороны. Но я просил не калькулятор! Но и за это спасибо.
Я хотел, чтобы ты сделал макрос, который бы преобразовывал выражение
(1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2) в список
(- (* (+ 1 4) (/ 8 4)) (* 2 (- (+ 1 (* 2 4)) 2))),
а не вычислял его. См. выше. Ну да ладно.
Я думал, что в процессе реализации, ты задумаешься над тем, как реализована поддержка ` , ,@ (или даже '). Дело в том, что системный repl реализован не напрямую через eval, а через предварительный препроцессор. Который форматирует входные списки перед передачей на системный eval. А так как системный repl находится в недоступной для нас области (видимости), то модифицировать его мы не сможем, даже если захотим.

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1004   2009-12-31 04:49 GMT+3 часа(ов)      
> Но я просил не калькулятор!
> Я хотел, чтобы ты сделал макрос, который бы преобразовывал выражение
> (1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2) в список
> (- (* (+ 1 4) (/ 8 4)) (* 2 (- (+ 1 (* 2 4)) 2))),
Элементарно, нужно немного подправить две функции:
(define (apply-op mop t)
(let ((e (car t))
(op (cadr t))
(nt (cddr t)))
(if (eq? op mop)
(cons `(,op ,e ,(car nt)) (cdr nt)) ;ТУТ
(append (list e op)
(apply-op mop nt)))))
 
(define (i2: t)
(let* ((elm (get-elm t))
(nelm (map (lambda (e)
(cond ((number? e) e)
((list? e) (i2: e))))
elm))
(nt (change nelm t)))
(apply i1:
(map (lambda (x)
(if (list? x) ;И ТУТ
x
(eval x (scheme-report-environment 5))))
nt))))
 
#| test
> (format-infix: (1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2))
(#<procedure:->
(#<procedure:*> (#<procedure:+> 1 4) (#<procedure:/> 8 4))
(#<procedure:*>
2
(#<procedure:+> 1 (#<procedure:-> (#<procedure:*> 2 4) 2))))
 
> (eval (format-infix: (1 + 4) * (8 / 4) - 2 * (1 + 2 * 4 - 2)) (scheme-report-environment 5))
-4
|#

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1006   2009-12-31 05:08 GMT+3 часа(ов)      
Молодца! Вот только для полного комфорта необходимо избавиться от шляпы #<procedure:xxx>.
И добавить возможность использовать переменные.
> (define x 8)
> (format-infix: (x + 4) * (8 / 4) - x * (1 + 2 * 4 - 2))
(- (* (+ 8 4) (/ 8 4)) (* 8 (- (+ 1 (* 2 4)) 2)))

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1007   2009-12-31 06:08 GMT+3 часа(ов)      
> Вот только для полного комфорта необходимо
> избавиться от шляпы #<procedure:xxx>.
> И добавить возможность использовать переменные.
(define (op->num op)
(cond ((eq? op '*) 4) ;тут ' добавил
((eq? op '/) 3)
((eq? op '-) 2)
((eq? op '+) 1)))
 
(define (num->op n)
(cond ((= n 4) '*) ;тут ' добавил
((= n 3) '/)
((= n 2) '-)
((= n 1) '+)))
 
(define (i1: t) ;убрал . перед t
(if (null? (cdr t)) ;(cdr '(res)) => '()
(car t) ;(i: res) => res
(let* ((ops (get-ops t))
(mop (max-op ops))
(nt (apply-op mop t)))
(i1: nt)))) ;убрал лишнее
 
(define (i2: t)
(let* ((elm (get-elm t))
(nelm (map (lambda (e)
(cond ((or (symbol? e) ;добавил обработку
(number? e)) ;переменных
(eval e (interaction-environment)))
((list? e) (i2: e))))
elm))
(nt (change nelm t)))
(i1: nt))) ;убрал лишнее
 
#| test
> (define x 8)
> (format-infix: (x + 4) * (8 / 4) - x * (1 + 2 * 4 - 2))
(- (* (+ 8 4) (/ 8 4)) (* 8 (+ 1 (- (* 2 4) 2))))
 
> (eval (format-infix: (x + 4) * (8 / 4) - x * (1 + 2 * 4 - 2)) (scheme-report-environment 5))
-32
|#

отредактировал(а) Alex: 2009-12-31 06:28 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1011   2010-01-01 14:42 GMT+3 часа(ов)      
Привет! С Новым Годом!
Извини, я тебя немного запутал. Надо было не вычислять x, а пропускать его. т.е. необходимо пропускать все без предварительного вычисления.
> (format-infix: 6 + (4 * x + 8) * dfg + 23)
(+ (+ 6 (* (+ (* 4 x) 8) dfg)) 23)
> (format-infix: 6 + (4 * if + let*) * define + 23)
(+ (+ 6 (* (+ (* 4 if) let*) define)) 23)
>
Затем можно придумать infix-preprocessor:, который будет правильно форматировать все входные данные (код). Далее создать infix-repl и упаковать все в экзещник. И использовать по назначению
И еще у тебя как-то странно задан приоритет операторов. Обычно + - имеют одинаковый приоритет, как и пара / *. И их так и задают. Почему бы тебе не задать так: (list? (member 'op '(+ -))), вместо (eq? op +).

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1013   2010-01-01 15:00 GMT+3 часа(ов)      
Возможно сегодня, завтра я еще смогу тебе ответить, а затем меня тут не будет некоторое время (возможно даже неделю).

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1018   2010-01-01 21:13 GMT+3 часа(ов)      
Тебя тоже с Новым Годом!
(define (i2: t)
(let* ((elm (get-elm t))
(nelm (map (lambda (e)
(cond ((or (symbol? e) ;убрал предварительное
(number? e)) e) ;вычисление
((list? e) (i2: e))))
elm))
(nt (change nelm t)))
(i1: nt)))
 
#| test
> (format-infix: 6 + (4 * x + 8) * dfg + 23)
(+ (+ 6 (* (+ (* 4 x) 8) dfg)) 23)
 
> (format-infix: 6 + (4 * if + let*) * define + 23)
(+ (+ 6 (* (+ (* 4 if) let*) define)) 23)
 
> (define x 8)
> (format-infix: (x + 4) * (8 / 4) - x * (1 + 2 * 4 - 2))
(- (* (+ x 4) (/ 8 4)) (* x (+ 1 (- (* 2 4) 2))))
 
> (eval (format-infix: (x + 4) * (8 / 4) - x * (1 + 2 * 4 - 2))
(interaction-environment))
-32
|#
> Затем можно придумать infix-preprocessor:, который будет
> правильно форматировать все входные данные (код).
Поподробнее можно? А то я не совсем улавливаю, что нужно сделать.
Переносы строк, табуляции, это чтоли?

> Обычно + - имеют одинаковый приоритет, как и пара / *. \
> И их так и задают. Почему бы тебе не задать так:
> (list? (member 'op '(+ -))), вместо (eq? op +).
На конечный результат это никак не влияет, а читается легше.
Я просто стараюсь следовать принципу KISS.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1019   2010-01-01 23:45 GMT+3 часа(ов)      
>> Затем можно придумать infix-preprocessor:, который будет
>> правильно форматировать все входные данные (код).
>Поподробнее можно? А то я не совсем улавливаю, что нужно сделать.
>Переносы строк, табуляции, это чтоли?
Из моего предыдущего сообщения:
"... Дело в том, что системный repl реализован не напрямую через eval, а через предварительный препроцессор. Который форматирует входные списки перед передачей на системный eval. ..."
Реализуй собственный repl, например, можно так
InfixScheme  v0.0.1
 
 
[1] 67
67
[2] (define ^4 (lambda(v) (* v (v * v * v))))
[3] (^4 2)
16
[4]
InfixScheme  v0.0.1
 
 
[1] (define (fibonacci n)
(if (< n 2)
1
(+ (fibonacci (n - 1)) (fibonacci (n - 2)))))
[2] (fibonacci 6)
13
[3] (fibonacci 9)
55
[4] (fibonacci 24)
75025
[5]

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1024   2010-01-02 01:49 GMT+3 часа(ов)      
Если интересно можешь посмотреть мой код, но лучше написать свой
Конечно, в моем коде есть баги и его можно улучшить, но для меня это не так важно
Тестируй в DrScheme с Pretty Big. Я тестировал в Chez Scheme.
(define-syntax format-infix:
(syntax-rules ()
((_ (e ...))
(format-infix: e ...))
((_ e)
'e)
((_ e1 op e2)
(if (list? (member 'op '(+ - * /)))
`(op ,(format-infix: e1) ,(format-infix: e2))
'(e1 op e2)))
((_ e1 op1 e2 op2 e3 tail ...)
(if (list? (member 'op2 '(+ -)))
(eval `(format-infix:
(op1 ,(format-infix: e1) ,(format-infix: e2)) op2 e3
tail ...))
(if (list? (member 'op2 '(* /)))
(eval `(format-infix:
e1 op1 (op2 ,(format-infix: e2) ,(format-infix: e3))
tail ...))
(parse-infix: e1 op1 e2 op2 e3 tail ...))))
((_ e ...)
(parse-infix: e ...))))
 
(define-syntax parse-infix:
(syntax-rules ()
((_ (e1 e2 e3 ...))
(if (list? (member 'e2 '(+ - * /)))
`(,(format-infix: e1 e2 e3 ...))
`(,(parse-infix: e1 e2 e3 ... ()))))
((_ e)
'e)
((_ (e1 e2 e3 ...) e4 tail ...)
(if (list? (member 'e2 '(+ - * /)))
`(,(format-infix: e1 e2 e3 ...) ,@(parse-infix: e4 tail ...))
`(,(parse-infix: e1 e2 e3 ...()) ,@(parse-infix: e4 tail ...))))
((_ e1 e2 ...)
`(e1 ,@(parse-infix: e2 ...)))))
 
(define (infix-preprocessor: . expr)
(cond
((null? (car expr)) '())
((list? (car expr)) (car (eval `(parse-infix: ,@expr))))
(else (car expr))))
 
(define infix-void (eval '(define infix-void #f)))
(define str-count 0)
(define (str-count++) (set! str-count (+ str-count 1)) str-count)
 
(define (INFIX-REPL)
(display "[") (write (str-count++)) (display "] ")
(let ((input (read)))
(if (not (eof-object? input))
(begin
(let ((prep (eval (infix-preprocessor: input))))
(if (not (equal? prep infix-void))
(begin
(if (procedure? prep)
(write (prep))
(write prep))
(newline))))
(INFIX-REPL))
(begin (display " End Of Data ") (newline)))))
 
(define (view-header-info)
(display "InfixScheme v0.0.1")
(newline) (newline) (newline))
 
(define (infix-scheme)
(view-header-info)
(INFIX-REPL))
 
(infix-scheme)

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1027   2010-01-02 03:02 GMT+3 часа(ов)      
Сия халтура мне не нравится, а именно, твой format-infix:. Он у тебя расчитан только на + - / *. Поробуй, например, добавить обработку оператора modulo - остаток от деления, и пускай у него будет приоритет ниже, чем у + -. А потом попробуй обобщить свой код на n-е количество операторов разного приоритета. Посмотрим, насколько изменится твой код по сравнению с начальной версией.

P.S. Хорошо, я постараюсь написать "препроцессор", но попозже, счас дел много.

отредактировал(а) Alex: 2010-01-02 03:28 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1028   2010-01-02 05:20 GMT+3 часа(ов)      
Цитата
Alex :
Сия халтура мне не нравится, а именно, твой format-infix:. Он у тебя расчитан только на + - / *. Поробуй, например, добавить обработку оператора modulo - остаток от деления, и пускай у него будет приоритет ниже, чем у + -. А потом попробуй обобщить свой код на n-е количество операторов разного приоритета. Посмотрим, насколько изменится твой код по сравнению с начальной версией.

P.S. Хорошо, я постараюсь написать "препроцессор", но попозже, счас дел много.


(define (<> a b) (not (= a b)))
 
(define (infix-get-prioritet op)
(cond
((list? (member op '(* / modulo))) 5)
((list? (member op '(+ -))) 4)
((list? (member op '(> < <= =>))) 3)
((list? (member op '(= <>))) 2)
((list? (member op '(or and))) 1)
(else #f)))
 
(define-syntax format-infix:
(syntax-rules ()
((_ (e ...))
(format-infix: e ...))
((_ e)
'e)
((_ e1 op e2)
(if (infix-get-prioritet 'op)
`(op ,(format-infix: e1) ,(format-infix: e2))
(parse-infix: e1 op e2 ())))
((_ e1 op1 e2 op2 e3 tail ...)
(if (infix-get-prioritet 'op1)
(if (> (infix-get-prioritet 'op1) (infix-get-prioritet 'op2))
(eval `(format-infix:
(op1 ,(format-infix: e1) ,(format-infix: e2)) op2 e3
tail ...))
(eval `(format-infix:
e1 op1 (op2 ,(format-infix: e2) ,(format-infix: e3))
tail ...)))
(parse-infix: e1 op1 e2 op2 e3 tail ...)))
((_ e ...)
(parse-infix: e ...))))
 
(define-syntax parse-infix:
(syntax-rules ()
((_ (e1 e2 e3 ...))
(if (infix-get-prioritet 'e2)
`(,(format-infix: e1 e2 e3 ...))
`(,(parse-infix: e1 e2 e3 ... ()))))
((_ e) 'e)
((_ (e1 e2 e3 ...) e4 tail ...)
(if (infix-get-prioritet 'e2)
`(,(format-infix: e1 e2 e3 ...) ,@(parse-infix: e4 tail ...))
`(,(parse-infix: e1 e2 e3 ...()) ,@(parse-infix: e4 tail ...))))
((_ e1 e2 ...)
`(e1 ,@(parse-infix: e2 ...)))))

отредактировал(а) misha: 2010-01-02 05:42 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1029   2010-01-02 05:25 GMT+3 часа(ов)      
Ну как халтурка сильно изменилась? Можно конечно и infix-preprocessor: поправить.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1030   2010-01-02 05:50 GMT+3 часа(ов)      
Между нашими format-infix: разница лишь в том, что у меня выражение разбирается с головы, а у тебя с хвоста

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1032   2010-01-02 18:36 GMT+3 часа(ов)      
Я немного исправил, добавил возможность трассировки "синтаксического" разбора выражений. Теперь и у меня разбор с хвоста Введение _skip_ - это цена за уменьшение проходов.
(define TraceRules? #f)
 
(define (TraceRules nrule val)
(if TraceRules?
(begin (display "StepRule ") (write nrule) (display " : ")
(write val) (newline)))
val)
 
(define-syntax format-infix:
(syntax-rules (_skip_)
((_ (_skip_ e))
(TraceRules 9
'e))
((_ (e ...))
(TraceRules 1
(format-infix: e ...)))
((_ e)
'e)
((_ e1 op e2)
(TraceRules 2
(if (infix-get-prioritet 'op)
`(op ,(format-infix: e1) ,(format-infix: e2))
(parse-infix: e1 op e2 ()))))
((_ e1 op1 e2 op2 e3 tail ...)
(TraceRules 3
(if (infix-get-prioritet 'op1)
(if (>= (infix-get-prioritet 'op1) (infix-get-prioritet 'op2))
(eval `(format-infix:
(_skip_ (op1 ,(format-infix: e1) ,(format-infix: e2))) op2 e3
tail ...))
(eval `(format-infix:
e1 op1 (_skip_ (op2 ,(format-infix: e2) ,(format-infix: e3)))
tail ...)))
(parse-infix: e1 op1 e2 op2 e3 tail ...))))
((_ e ...)
(TraceRules 4
(parse-infix: e ...)))))
 
(define-syntax parse-infix:
(syntax-rules (_skip_)
((_ (_skip_ e))
(TraceRules 10
'e))
((_ (e1 e2 e3 ...))
(TraceRules 5
(if (infix-get-prioritet 'e2)
`(,(format-infix: e1 e2 e3 ...))
`(,(parse-infix: e1 e2 e3 ... ())))))
((_ e)
(TraceRules 6
'e))
((_ (e1 e2 e3 ...) e4 tail ...)
(TraceRules 7
(if (infix-get-prioritet 'e2)
`(,(format-infix: e1 e2 e3 ...) ,@(parse-infix: e4 tail ...))
`(,(parse-infix: e1 e2 e3 ...()) ,@(parse-infix: e4 tail ...)))))
((_ e1 e2 ...)
(TraceRules 8
`(e1 ,@(parse-infix: e2 ...))))))
 
(define (infix-preprocessor: . expr)
(cond
((null? (car expr)) '())
((and (list? (car expr)) (not (null? (cdar expr))))
(car (eval `(parse-infix: ,@expr))))
(else (car expr))))
 
(define (INFIX-REPL)
(display "[") (write (str-count++)) (display "] ")
(let ((input (read)))
(if (not (eof-object? input))
(begin
(let ((prep (eval (infix-preprocessor: input))))
(if (not (equal? prep infix-void)) (begin (write prep) (newline))))
(INFIX-REPL))
(begin (display " End Of Data ") (newline)))))

отредактировал(а) misha: 2010-01-02 18:42 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1033   2010-01-02 18:45 GMT+3 часа(ов)      
Разбор с хвоста
(if (>= (infix-get-prioritet 'op1) (infix-get-prioritet 'op2)) 

С головы
(if (> (infix-get-prioritet 'op1) (infix-get-prioritet 'op2)) 

Alex

Members


Статус

54 сообщений

Где: Belarus Александранск
Род занятий:
Возраст: 29

#1036   2010-01-02 20:41 GMT+3 часа(ов)      
> Ну как халтурка сильно изменилась?
Как была халтуркой, так и осталась халтуркой:
> (format-infix: 1 or 4 - 3 * 6)
(or 1 (* (- 4 3) 6))
А должно быть
(or 1 (- 4 (* 3 6)))

> Между нашими format-infix: разница лишь в том, что
> у меня выражение разбирается с головы, а у тебя с хвоста
Ничего подобного. У меня совсем по другому вычисляется выражение: среди всех операторов в выражении ищется с максимальным приоритетом, а потом я применяю этот оператор к соседним элементам, тем самым уменьшая размерность выражения и т.д. покуда не получу результат. У тебя же программа пока расчитана на правильную работу только с двумя приоритетами, не более.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1037   2010-01-02 22:19 GMT+3 часа(ов)      
Да это я проглядел
(define-syntax format-infix:
(syntax-rules ()
((_ (e ...))
(TraceRules 1
(format-infix: e ...)))
((_ e)
'e)
((_ e1 op e2)
(TraceRules 2
(if (infix-get-prioritet 'op)
`(op ,(format-infix: e1) ,(format-infix: e2))
(parse-infix: e1 op e2 ()))))
((_ e1 op1 e2 op2 e3 tail ...)
(TraceRules 3
(if (and (infix-get-prioritet 'op1) (infix-get-prioritet 'op2))
(if (>= (infix-get-prioritet 'op1) (infix-get-prioritet 'op2))
(eval `(format-infix:
,(format-infix: e1 op1 e2) op2 e3 tail ...))
(eval `(format-infix:
e1 op1 ,(parse-infix: e2 op2 e3 tail ... ()))))
(parse-infix: e1 op1 e2 op2 e3 tail ... ()))))
((_ e ...)
(TraceRules 4
(parse-infix: e ... ())))))

отредактировал(а) misha: 2010-01-03 03:33 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1038   2010-01-02 22:29 GMT+3 часа(ов)      
> (format-infix: 2 and 1 * (+ 5 6) or 4 - 3 * 6)
(and 2 (or (* 1 (+ 5 6)) (- 4 (* 3 6))))
> (format-infix: 2 and 1 * (+ 9 (5 + 6 - 9) 5 6) or 4 - 3 * 6)
(and 2 (or (* 1 (+ 9 (- (+ 5 6) 9) 5 6)) (- 4 (* 3 6))))

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1103   2010-01-09 21:56 GMT+3 часа(ов)      
Недавно переписал все с нуля. На все ушло около 4 часов.
(define (<> a b) (not (= a b)))
 
(define infix-operators '(
(not 9 unary right-left)
(* 5 binary left-right)
(/ 5 binary left-right)
(modulo 5 binary left-right)
(+ 4 binary left-right)
(- 4 binary left-right)
(> 3 binary left-right)
(< 3 binary left-right)
(>= 3 binary left-right)
(<= 3 binary left-right)
(= 2 binary left-right)
(<> 2 binary left-right)
(or 1 binary left-right)
(and 1 binary left-right)))
 
(define (infix-operator? op)
(let loop ((ex infix-operators))
(cond
((null? ex) #f)
((eqv? op (caar ex)) #t)
(else (loop (cdr ex))))))
 
(define (infix-get-prioritet op)
(let loop ((ex infix-operators))
(cond
((null? ex) #f)
((eqv? op (caar ex)) (cadar ex))
(else (loop (cdr ex))))))
 
(define (infix-get-class op)
(let loop ((ex infix-operators))
(cond
((null? ex) #f)
((eqv? op (caar ex)) (caddar ex))
(else (loop (cdr ex))))))
 
(define (infix-get-associativity op)
(let loop ((ex infix-operators))
(cond
((null? ex) #f)
((eqv? op (caar ex)) (car (cdddar ex)))
(else (loop (cdr ex))))))
 
(define (infix-unary-rl expr)
(let ((res '()) (tail '()) (err #f))
(set! res
(let loop ((head expr))
(if (and (eqv? (infix-get-class (car head)) 'unary)
(eqv? (infix-get-associativity (car head)) 'right-left)
(not (null? (cdr head))))
(cond
((and (eqv? (infix-get-class (cadr head)) 'unary)
(eqv? (infix-get-associativity (cadr head)) 'right-left))
(if (cdr head)
(cons (car head) `(,(loop (cdr head))))))
((and (not (infix-operator? (cadr head)))
(not (null? (cadr head))))
(cond
((null? (cddr head))
(begin (set! tail (cddr head))
(list (car head) (cadr head))))
((eqv? (infix-get-class (caddr head)) 'binary)
(if (>= (infix-get-prioritet (car head))
(infix-get-prioritet (caddr head)))
(begin (set! tail (cddr head))
(list (car head) (cadr head)))
`(,(car head) ,(infix-format (cdr head))))) ; error?)))
(else
(begin (set! err #t)
'()))))
(else
(begin (set! err #t)
'())))
(begin (set! err #t)
'()))))
(if err
expr
(if (null? tail)
`(,res)
`(,res ,@tail)))))
 
(define (infix-unary-rl-ops expr)
(let loop ((head expr))
(cond
((null? head)
'())
((and (eqv? (infix-get-class (car head)) 'unary)
(eqv? (infix-get-associativity (car head)) 'right-left)
(not (null? (cdr head))))
(let ((v (infix-unary-rl head)))
(if (list? (car v))
(cons (car v) (loop (cdr v)))
v)))
(else
(cons (car head) (loop (cdr head)))))))
 
(define (infix-parentheses expr)
(let loop ((head expr))
(cond
((null? head)
'())
((and (list? (car head))
(not (null? (car head))))
(cons (infix-format (car head)) (loop (cdr head))))
(else
(cons (car head) (loop (cdr head)))))))
 
(define (infix-format expr)
(if (or (null? expr)
(not (list? expr)))
expr
(let ((res1 (infix-parentheses expr)) (res '()) (err #f))
(set! res
(let loop ((head (infix-unary-rl-ops res1)))
(cond
((null? head)
'())
((null? (cdr head))
head)
((>= (length head) 4)
(cond
((and (not (infix-operator? (car head))) ; 1
(not (infix-operator? (caddr head)))) ; 3
(if (and (eqv? (infix-get-class (cadr head)) 'binary) ; 2
(eqv? (infix-get-class (cadddr head)) 'binary)) ; 4
(if (>= (infix-get-prioritet (cadr head)) (infix-get-prioritet (cadddr head)))
(loop
(cons `(,(cadr head) ,(car head) ,(caddr head)) (cdddr head)))
`(,(cadr head) ,(car head)
,(loop (cddr head))))
(begin (set! err #t) '())))
(else
(begin (set! err #t) '()))))
((= (length head) 3)
(if (and (not (infix-operator? (car head))) ; 1
(eqv? (infix-get-class (cadr head)) 'binary) ; 2
(not (infix-operator? (caddr head))) ; 3
(not (null? (caddr head)))) ; 3
`(,(cadr head) ,(car head) ,(caddr head))
(begin (set! err #t) '())))
(else
(begin (set! err #t) '())))))
(if err
res1
res))))
; may be delete!
(current-exception-handler (lambda (exc) (display "Get error: ") (pp exc)))
 
(define infix-void (void))
(define str-count 0)
(define (str-count++) (set! str-count (+ str-count 1)) str-count)
 
(define (infix-preprocessor expr)
(cond
((eqv? ':q expr) (exit))
((list? expr) (infix-format expr))
(else expr)))
 
(define (INFIX-REPL)
(display "[") (write (str-count++)) (display "] ")
(let ((input (read)))
(if (not (eof-object? input))
(begin
(let ((prep (eval (infix-preprocessor input))))
(if (not (equal? prep infix-void)) (begin (write prep) (newline))))
(INFIX-REPL))
(begin (display " End Of Data ") (newline)))))
 
(define (view-header-info)
(display "InfixScheme v0.0.2")(newline)
(display "Type :q to exit.")
(newline) (newline) (newline))
 
(define (infix-scheme)
(view-header-info)
(INFIX-REPL))
 
(infix-scheme)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1104   2010-01-09 23:06 GMT+3 часа(ов)      
Если лень компилировать, то вот ссылка на экзешник.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#1956   2010-05-05 16:09 GMT+3 часа(ов)      
Немного улучшенная(упрощенная) версия здесь.

отредактировал(а) misha: 2010-05-07 14:37 GMT+3 часа(ов)

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#4072   2011-03-24 23:02 GMT+3 часа(ов)      
Перевел старый исходник с r5rs на Рэкет. (исходник)
> (let ([x 45]) 
(infix: 12 + x * 2))
102
> (infix: 6 + (4 * 5 + 8) * 7 + 23)
225
> (infix: #%test 6 + (4 * 5 + 8) * 7 + 23)
'(+ 6 (+ (* (+ (* 4 5) 8) 7) 23))
> (infix: #%test 2 and 1 * (9 + (5 + 6 - 9) + 5 + 6) or 4 - 3 * 6)
'(and 2 (or (* 1 (+ (+ (+ 9 (- (+ 5 6) 9)) 5) 6)) (- 4 (* 3 6))))
> (infix: 2 and 1 * (9 + (5 + 6 - 9) + 5 + 6) or 4 - 3 * 6)
22
> (infix: #%test
define (fact n)
(if (n = 0) 1
(n * (fact (n - 1)))))
'(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
> (infix: define (fact n)
(if (n = 0) 1
(n * (fact (n - 1)))))
> (fact 10)
3628800

Kergan

Members


Статус

300 сообщений

Где: ---
Род занятий:
Возраст:

#4488   2011-06-30 14:25 GMT+3 часа(ов)      
Цитата
misha :
Перевел старый исходник с r5rs на Рэкет. (исходник)


Вот так вот:
 
(syntax-case so (#%test)
[(_ #%test . rest)
#`'#,(infix-trans (syntax->datum #'rest))]
[(_ . rest)
(datum->syntax so (infix-trans (syntax->datum #'rest)))])
 

делать ни в коем случае нельзя, вы запороли всю гигиену. Надо либо руками разбирать syntax-object, либо парсить при помощи паттернов. Кроме того, надо учитывать биндинги идентификаторов. Например, у вас внутри инфикс формы может оказаться нечто вроде:
 
(let ([+ 10])
(* + 2))
 

и будет ошибка, хотя форма должна вернуть 20. На syntax-parse макросов без подобных огрех можно сделать как-нибудь так:
 
#lang racket
 
(require (for-syntax "syntax-match.rkt"
syntax/boundmap))
 
(provide (except-out (all-from-out racket) #%app)
(rename-out [infix #%app])
infix-set!)
 
(define-for-syntax infix-hash (make-free-identifier-mapping))
 
(define-syntax-rule (infix-set! (name p assoc) ...)
(begin-for-syntax (free-identifier-mapping-put! infix-hash
#`name
(cons (syntax->datum #`p)
(syntax->datum #`assoc))) ...))
 
(define-syntax infix
(syntax-match
 
(define-syntax-class op
(pattern x:id
#:when (free-identifier-mapping-get infix-hash #`x (&&#35955; () #f))))
 
(define-syntax-class (infix-op n assoc)
(pattern x:op
#:when (and (= n (car (free-identifier-mapping-get infix-hash #`x (&&#35955; () #f))))
(eq? assoc (cdr (free-identifier-mapping-get infix-hash #`x (&&#35955; () #f)))))))
 
(define-syntax-class (nop n)
(pattern (x ...)
#:with expr #`(infix x ...))
(pattern (~and y (~not (~or (~var x (infix-op n 'right))
(~var x (infix-op n 'left)))))
#:with expr #`y))
 
(define-syntax-class base-expr
(pattern x
#:with expr #`x))
 
(define-syntax-class (infix-expr n)
(pattern (~or ((~or (~var l (nop n)) (~seq lm ...+))
(~var o (infix-op n 'left))
(~or (~var r (nop n)) (~seq (~var rm (nop n)) ...+)))
((~or (~var l (nop n)) (~seq (~var lm (nop n)) ...+))
(~var o (infix-op n 'right))
(~or (~var r (nop n)) (~seq rm ...+))))
#:with expr #`(o #,(if (attribute l) #`l.expr #`(infix lm ...))
#,(if (attribute r) #`r.expr #`(infix rm ...))))
(pattern rec
#:fail-when (> n 10) #f
#:with (~var tmp (infix-expr (add1 n))) #`rec
#:with expr #`tmp.expr))
 
(:: (_ fun args ...)
[(~or (~var x (infix-expr 0)) x:base-expr)
<- #`(fun args ...)]
-> #`x.expr)))
 
(infix-set! (+ 5 left)
(- 5 left)
(* 6 left)
(/ 6 left))

использовать как-то так:
 
#lang s-exp "infix.rkt"
 
(1 + 2 * (3 - 4) * 6) ; -> -11
 
(infix-set! (= 5 left))
 
(define (fact n)
(if (n = 0)
1
(n * (fact (n - 1)))))
 
(fact 5) ; -> 120
 

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#4489   2011-06-30 17:51 GMT+3 часа(ов)      
> делать ни в коем случае нельзя, вы запороли всю гигиену. Надо либо руками разбирать syntax-object, либо парсить при помощи паттернов.
Рекурсивные макросы жутко тормозят (по объективным причинам). Я выбираю производительность!

> и будет ошибка, хотя форма должна вернуть 20.
Так для меня эта форма является "ошибкой".

> На syntax-parse макросов без подобных огрех можно сделать как-нибудь так:
Из пушки по воробьям! Мне ваши паттерны не внушают доверия.

Зачем вы используете (lambda() #f), когда необходимо создавать исключение?

Kergan

Members


Статус

300 сообщений

Где: ---
Род занятий:
Возраст:

#4490   2011-06-30 20:52 GMT+3 часа(ов)      
Цитата

Рекурсивные макросы жутко тормозят (по объективным причинам). Я выбираю производительность!


Ну, во-первых, рекурсивные макросы работают не намного медленнее. Во-вторых - основное дело тут не в рекурсивных макросах, а в том, что вы безвозвратно теряете всю информацию о синтаксическом объекте, в результате чего отменяете работу гигиены. Вот вам такой пример:
 
#lang racket
 
(define-syntax (infix stx)
(syntax-case stx ()
[(_ expr) (datum->syntax stx (syntax->datum #`expr))]))
 
(define-syntax-rule (test expr)
(infix (let ([tmp 10]) expr)))
 
(let ([tmp 20]) (test (display tmp))) ; -> выводит 10 должно быть 20
 

Подобные небезопасные макросы, естественно, использовать ни в коем случае нельзя - ведь любой макрос, раскрывающийся в такой infix (или раскрывающийся в раскрывающийся в infix ... и т.д.) тоже становится небезопасен. Возникновение трудноотлаживаемой ошибки со временем гарантировано.
Вторую проблему я уже назвал в предыдущем посте - вы сравниваете символы, а не идентификаторы, в результате чего не учитываются биндинги (что снова ведет к снижению безопасности). Эти две проблемы можно решить, заменив ваш хеш символов на хеш идентификаторов, и используя syntax->list, syntax-e (или паттерны, которые раскроются в те же syntax->list syntax-e) вместо еретических syntax->datum. Третья проблема (вот теперь как раз о том, почему задача должна решаться именно при помощи рекурсивных макросов) - head формы внутри infix может быть макросом. Например, есть макрос test, у вас внутри инфикса написано (test + 2), ваш инфикс превратит это в (+ test 2) - ошибка. Специально для этого в racket и введены формы наподобие #%app - их переопределение в совокупности с гигиеной полностью решает эту проблему - при раскрытии test будет использоваться #%app из области определения test, так что инфиксное преобразование внутри раскрытого тела макроса будет выполнено только в том случак, когда оно будет нужным. Вы же сразу кинулись на написание кодеволкера (богатый опыт CL?). В Racket если вам хочется написать кодеволкер - значит, вы делаете что-то не то. 99% существуют средства для реализации более простого, удобного и надежного решения задачи. Недаром plt-team позиционирует макросистему Racket главной киллер-фичей

Цитата

Из пушки по воробьям!


Ну вы же сами решили задачу на паттернах, только матчили списки, а не синтаксические объекты.

Цитата

Мне ваши паттерны не внушают доверия.


Почему же?

Цитата

Зачем вы используете (lambda() #f), когда необходимо создавать исключение?


За тем, что в данном случае (если идентификатор не является оператором) надо возвращать #f, а не кидать исключение.

misha

Moderators


Статус

1275 сообщений
http://racket-lang.org/
Где: Yemen
Род занятий:
Возраст:

#4491   2011-06-30 23:11 GMT+3 часа(ов)      
> Ну, во-первых, рекурсивные макросы работают не намного медленнее.
Как раз намного медленнее.

> Во-вторых - основное дело тут не в рекурсивных макросах, а в том, что вы безвозвратно теряете всю информацию о синтаксическом объекте, в результате чего отменяете работу гигиены.
А зачем мне она нужна, если я рассматриваю +, - и др. как операторы, а не как идентификаторы с их привязками.

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

> Эти две проблемы можно решить, заменив ваш хеш символов на хеш идентификаторов, и используя syntax->list, syntax-e (или паттерны, которые раскроются в те же syntax->list syntax-e) вместо еретических syntax->datum.
Это не решит проблему.
(define stxlist (syntax->list 
#'(let ([+ 45]) +)))
 
(define x1 (car (syntax->list
(car (syntax->list
(cadr stxlist))))))
(define x2 (caddr stxlist))
 
(identifier-binding x1)
(identifier-binding x2)


> Третья проблема (вот теперь как раз о том, почему задача должна решаться именно при помощи рекурсивных макросов) - head формы внутри infix может быть макросом.
Вы решили эту проблему?

> Вы же сразу кинулись на написание кодеволкера (богатый опыт CL?).
А почему вы его не написали? Я желаю видеть промежуточные преобразования с идентификаторами вида X:ID (коль вы рассуждаете о биндингах). Например, (let ([+ 45]) +) ==> (let ([+:1 45]) +:1)

> В Racket если вам хочется написать кодеволкер - значит, вы делаете что-то не то.
Глупость. Я с Лиспом знаком уже более 6 лет, и я не раз встречал самописные кодеволкеры, причем в большинстве случаев это оправдано.

> 99% существуют средства для реализации более простого, удобного и надежного решения задачи.
Какой задачи? Чем проще макрос, тем лучше. А использование чужих либ как раз и является основной причиной "возникновения трудноотлаживаемых ошибок".

> Недаром plt-team позиционирует макросистему Racket главной киллер-фичей
Какой фичей?

> Ну вы же сами решили задачу на паттернах, только матчили списки, а не синтаксические объекты.
Гигиена требует макротрансформации результата, т.е. синтаксического объекта.

> Почему же?
А где "syntax-match.rkt"?

> За тем, что в данном случае (если идентификатор не является оператором) надо возвращать #f, а не кидать исключение.
Это здесь что ли?
(and (= n (car (free-identifier-mapping-get infix-hash #`x (&&#35955; () #f))))
(eq? assoc (cdr (free-identifier-mapping-get infix-hash #`x (&&#35955; () #f)))))))

Kergan

Members


Статус

300 сообщений

Где: ---
Род занятий:
Возраст:

#4492   2011-07-01 00:03 GMT+3 часа(ов)      
Цитата
Как раз намного медленнее.

В 2-3 раза разница, в данном случае это не много.

Цитата
А зачем мне она нужна, если я рассматриваю +, - и др. как операторы, а не как идентификаторы с их привязками.

А при чем тут +/- и т.д.? Смотрите выше пример с перекрытием переменной tmp.

Цитата
Вы утрируете

Никакого утрирования, ошибки в данном случае гарантированы. Рано или поздно кто-то забудет о том, что макрос небезопасен, напишет (на первый взгляд) гигиеничный код и получит черте что.

Цитата
Это не решит проблему.

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

Цитата
Вы решили эту проблему?

Да.

Цитата
А почему вы его не написали?

Зачем? Смысл писать кодеволкер, если есть альтернативное решение, которое и проще и намного качественнее?

Цитата
Я желаю видеть промежуточные преобразования с идентификаторами вида X:ID (коль вы рассуждаете о биндингах). Например, (let ([+ 45]) +) ==> (let ([+:1 45]) +:1)

А там у идентификаторов будет одинаковый вид - одинаковое имя, одинаковый набор марок. Отличаться будут биндинги и source location. Вообще - можете сами посмотреть в макростепере, как оно раскрывается.

Цитата
Глупость. Я с Лиспом знаком уже более 6 лет, и я не раз встречал самописные кодеволкеры, причем в большинстве случаев это оправдано.

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

Цитата
Какой задачи? Чем проще макрос, тем лучше.

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

Цитата
А использование чужих либ как раз и является основной причиной "возникновения трудноотлаживаемых ошибок".

Там нет "чужих либ" - если таковой не считать стандартную библиотеку. Хотя, конечно, если предположить, что большую часть либ пишут так же как вы infix, то действительно стоит опасаться, а то мало ли что там унутре

Цитата
Какой фичей?

Скажем так, ключевым плюсом Racket по отношению к другим фреймворкам.

Цитата
Гигиена требует макротрансформации результата, т.е. синтаксического объекта.

Ну да. Так при чем тут пушка по воробьям? Вы матчили списки, с таким же успехом можно было так же матчить синтаксические объекты (те же списки но с некоторым доп. набором информации)

Цитата
А где "syntax-match.rkt"?

Oops! Это мой личный макрос, который я для себя писал, ну и всунул по привычке. Но он тут не нужен, можно обойтись обычным syntax-parse, ничего не изменится. "syntax-match.rkt" надо поменять на syntax/parse а
 
(define-syntax infix
(syntax-match stx
 
*здесь формы define-syntax-class*
 
(:: (_ fun args ...)
[(~or (~var x (infix-expr 0)) x:base-expr)
<- #`(fun args ...)]
-> #`x.expr)))
 
 

поменять на
 
(define-syntax (infix stx)
 
*теперь все define-syntax-class здесь*
 
(syntax-parse stx
[(_ fun arg ...)
(syntax-parse #`(fun arg ...)
[(~or (~var x (infix-expr 0)) x:base-expr)
#`x.expr])]))
 


Цитата
Это здесь что ли?

Ну да. А что вас смущает.


Онлайн :

0 пользователь(ей), 31 гость(ей) :




Реклама на сайте: