aboutsummaryrefslogtreecommitdiff
path: root/Semestr 2/racket/l10z18
diff options
context:
space:
mode:
Diffstat (limited to 'Semestr 2/racket/l10z18')
-rw-r--r--Semestr 2/racket/l10z18/solution.bak363
-rw-r--r--Semestr 2/racket/l10z18/solution.rkt409
2 files changed, 0 insertions, 772 deletions
diff --git a/Semestr 2/racket/l10z18/solution.bak b/Semestr 2/racket/l10z18/solution.bak
deleted file mode 100644
index 02eb770..0000000
--- a/Semestr 2/racket/l10z18/solution.bak
+++ /dev/null
@@ -1,363 +0,0 @@
-#lang racket
-
-;; Składnia abstrakcyjna
-(struct const (val) #:transparent)
-(struct var-expr (name) #:transparent)
-(struct let-expr (id bound body) #:transparent)
-(struct letrec-expr (id bound body) #:transparent)
-(struct if-expr (eb et ef) #:transparent)
-(struct lambda-expr (arg body) #:transparent)
-(struct app-expr (fun arg) #:transparent)
-
-(define (keyword s)
- (member s '(true false null and or if cond else lambda let letrec)))
-
-(define (expr? e)
- (match e
- [(const n) (or (number? n)
- (boolean? n)
- (null? n)
- (string? n))]
- [(var-expr id) (symbol? id)]
- [(let-expr x e1 e2 ) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(letrec-expr x e1 e2) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(if-expr eb et ef) (and (expr? eb)
- (expr? et)
- (expr? ef))]
- [(lambda-expr x e) (and (symbol? x)
- (expr? e))]
- [(app-expr ef ea) (and (expr? ef)
- (expr? ea))]
- [_ false]))
-
-;; Parsowanie (zacytowane wyrażenie -> składnia abstrakcyjna)
-(define (parse q)
- (cond
- [(number? q) (const q)]
- [(string? q) (const q)]
- [(eq? q 'true) (const true)]
- [(eq? q 'false) (const false)]
- [(eq? q 'null) (const null)]
- [(and (symbol? q)
- (not (keyword q)))
- (var-expr q)]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'let)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (let-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'letrec)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (letrec-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 4)
- (eq? (first q) 'if))
- (if-expr (parse (second q))
- (parse (third q))
- (parse (fourth q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'and))
- (desugar-and (map parse (cdr q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'or))
- (desugar-or (map parse (cdr q)))]
- [(and (list? q)
- (>= (length q) 2)
- (eq? (first q) 'cond))
- (parse-cond (cdr q))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'lambda)
- (list? (second q))
- (andmap symbol? (second q))
- (cons? (second q)))
- (desugar-lambda (second q) (parse (third q)))]
- [(and (list? q)
- (>= (length q) 2))
- (desugar-app (parse (first q)) (map parse (cdr q)))]
- [else (error "Unrecognized token:" q)]))
-
-(define (parse-cond qs)
- (match qs
- [(list (list 'else q))
- (parse q)]
-
- [(list (list q _))
- (error "Expected 'else' in last branch but found:" q)]
-
- [(cons (list qb qt) qs)
- (if-expr (parse qb) (parse qt) (parse-cond qs))]))
-
-(define (desugar-and es)
- (if (null? es)
- (const true)
- (if-expr (car es) (desugar-and (cdr es)) (const false))))
-
-(define (desugar-or es)
- (if (null? es)
- (const false)
- (if-expr (car es) (const true) (desugar-or (cdr es)))))
-
-(define (desugar-lambda xs e)
- (if (null? xs)
- e
- (lambda-expr (car xs) (desugar-lambda (cdr xs) e))))
-
-(define (desugar-app e es)
- (if (null? es)
- e
- (desugar-app (app-expr e (car es)) (cdr es))))
-
-;; Środowiska
-(struct blackhole ())
-(struct environ (xs))
-
-(define env-empty (environ null))
-(define (env-add x v env)
- (environ (cons (mcons x v) (environ-xs env))))
-(define (env-lookup x env)
- (define (assoc-lookup xs)
- (cond [(null? xs)
- (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (let ((v (mcdr (car xs))))
- (if (blackhole? v)
- (error "Jumped into blackhole at" x)
- v))]
- [else (assoc-lookup (cdr xs))]))
- (assoc-lookup (environ-xs env)))
-(define (env-update! x v env)
- (define (assoc-update xs)
- (cond [(null? xs) (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (set-mcdr! (car xs) v)]
- [else (assoc-update (cdr xs))]))
- (assoc-update (environ-xs env)))
-
-;; Domknięcia
-(struct clo (arg body env))
-
-;; Procedury wbudowane, gdzie
-;; proc — Racketowa procedura którą należy uruchomić
-;; args — lista dotychczas dostarczonych argumentów
-;; pnum — liczba brakujących argumentów (> 0)
-;; W ten sposób pozwalamy na częściową aplikację Racketowych procedur
-;; — zauważmy że zawsze znamy pnum, bo w naszym języku arność
-;; procedury jest ustalona z góry
-(struct builtin (proc args pnum) #:transparent)
-
-;; Pomocnicze konstruktory procedur unarnych i binarnych
-(define (builtin/1 p)
- (builtin (lambda (x) (return (p x))) null 1))
-(define (builtin/2 p)
- (builtin (lambda (x y) (return (p x y))) null 2))
-
-;; Procedury
-(define (proc? v)
- (or (and (clo? v)
- (symbol? (clo-arg v))
- (expr? (clo-body v))
- (environ? (clo-env v)))
- (and (builtin? v)
- (procedure? (builtin-proc v))
- (andmap value? (builtin-args v))
- (natural? (builtin-pnum v))
- (> (builtin-pnum v) 0))))
-
-;; Definicja typu wartości
-(define (value? v)
- (or (number? v)
- (boolean? v)
- (null? v)
- (string? v)
- (and (cons? v)
- (value? (car v))
- (value? (cdr v)))
- (proc? v)))
-
-;; Środowisko początkowe (przypisujące procedury wbudowane ich nazwom)
-
-(define start-env
- (foldl (lambda (p env) (env-add (first p) (second p) env))
- env-empty
- `((+ ,(builtin/2 +))
- (- ,(builtin/2 -))
- (* ,(builtin/2 *))
- (/ ,(builtin/2 /))
- (~ ,(builtin/1 -))
- (< ,(builtin/2 <))
- (> ,(builtin/2 >))
- (= ,(builtin/2 =))
- (<= ,(builtin/2 <=))
- (>= ,(builtin/2 >=))
- (not ,(builtin/1 not))
- (cons ,(builtin/2 cons))
- (car ,(builtin/1 car))
- (cdr ,(builtin/1 cdr))
- (pair? ,(builtin/1 cons?))
- (null? ,(builtin/1 null?))
- (boolean? ,(builtin/1 boolean?))
- (number? ,(builtin/1 number?))
- (procedure? ,(builtin/1 (lambda (x) (or (clo? x) (builtin? x)))))
- (string? ,(builtin/1 string?))
- (string-= ,(builtin/2 string=?))
- ;; and so on, and so on
- )))
-
-;; Efekt
-
-(define (effect-builtin/1 p)
- (builtin p null 1))
-(define (effect-builtin/2 p)
- (builtin p null 2))
-
-(define effect-env
- (foldl (lambda (p env) (env-add (first p) (second p) env))
- start-env
- `((choose ,(effect-builtin/2 (lambda (x y) (list x y))))
- )))
-
-(define (bind c k) (append-map k c))
-
-(define (return x) (list x))
-
-;; Ewaluator
-(define (eval-env e env)
- (match e
- [(const n)
- (return n)]
-
- [(var-expr x)
- (return (env-lookup x env))]
-
- [(let-expr x e1 e2)
- (bind (eval-env e1 env) (lambda (v1)
- (eval-env e2 (env-add x v1 env))))]
-
- [(letrec-expr f ef eb)
- (let ((new-env (env-add f (blackhole) env)))
- (bind (eval-env ef new-env) (lambda (vf)
- (env-update! f vf new-env)
- (eval-env eb new-env))))]
-
- [(if-expr eb et ef)
- (bind (eval-env eb env) (lambda (vb)
- (match vb
- [#t (eval-env et env)]
- [#f (eval-env ef env)]
- [v (error "Not a boolean:" v)])))]
-
- [(lambda-expr x e)
- (return (clo x e env))]
-
- [(app-expr ef ea)
- (bind (eval-env ef env) (lambda (vf)
- (bind (eval-env ea env) (lambda (va)
- (match vf
- [(clo x e env)
- (eval-env e (env-add x va env))]
- [(builtin p args nm)
- (if (= nm 1)
- (apply p (reverse (cons va args)))
- (return (builtin p (cons va args) (- nm 1))))]
- [_ (error "Not a function:" vf)])))))]))
-
-(define (eval e)
- (eval-env e effect-env))
-
-
-;; Przykladowy program
-
-(define PROGRAM
- '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2)))
-
-
-;; REPL — interpreter interaktywny (read-eval-print loop)
-
-;; dodajemy składnię na wiązanie zmiennych "na poziomie interpretera"
-;; i komendę wyjścia "exit" ...
-(struct letrec-repl (id expr))
-(struct let-repl (id expr))
-(struct exit-repl ())
-
-;; ... a także rozszerzoną procedurę parsującą te dodatkowe komendy i
-;; prostą obsługę błędów
-(define (parse-repl q)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Parse error! ")
- (displayln (exn-message exn)))])
- (cond
- [(eq? q 'exit) (exit-repl)]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'let))
- (let-repl (second q) (parse (third q)))]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'letrec))
- (letrec-repl (second q) (parse (third q)))]
- [else (parse q)])))
-
-;; trochę zamieszania w procedurze eval-repl wynika z rudymentarnej
-;; obsługi błędów: nie chcemy żeby błąd w interpretowanym programie
-;; kończył działanie całego interpretera!
-(define (eval-repl c env continue)
- (define (eval-with-err e env)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Error! ")
- (displayln (exn-message exn)))])
- (eval-env e env)))
- (match c
- [(exit-repl)
- (void)]
-
- [(let-repl x e)
- (let ((v (eval-with-err e env)))
- (if (void? v)
- (continue env)
- (continue (env-add x v env))))]
-
- [(letrec-repl f e)
- (let* ((new-env (env-add f (blackhole) env))
- (v (eval-with-err e new-env)))
- (if (void? v)
- (continue env)
- (begin
- (env-update! f v new-env)
- (continue new-env))))]
-
- [_
- (let ((v (eval-with-err c env)))
- (unless (void? v)
- (displayln v))
- (continue env))]))
-
-;; I w końcu interaktywny interpreter
-(define (repl)
- (define (go env)
- (display "FUN > ")
- (let* ((q (read))
- (c (parse-repl q)))
- (if (void? c)
- (go env)
- (eval-repl c env go))))
- (displayln "Welcome to the FUN functional language interpreter!")
- (go start-env)) \ No newline at end of file
diff --git a/Semestr 2/racket/l10z18/solution.rkt b/Semestr 2/racket/l10z18/solution.rkt
deleted file mode 100644
index 7adcea4..0000000
--- a/Semestr 2/racket/l10z18/solution.rkt
+++ /dev/null
@@ -1,409 +0,0 @@
-#lang racket
-
-;; Składnia abstrakcyjna
-(struct const (val) #:transparent)
-(struct var-expr (name) #:transparent)
-(struct let-expr (id bound body) #:transparent)
-(struct letrec-expr (id bound body) #:transparent)
-(struct if-expr (eb et ef) #:transparent)
-(struct lambda-expr (arg body) #:transparent)
-(struct app-expr (fun arg) #:transparent)
-
-(provide parse eval norm)
-
-(define (keyword s)
- (member s '(true false null and or if cond else lambda let letrec)))
-
-(define (expr? e)
- (match e
- [(const n) (or (number? n)
- (boolean? n)
- (null? n)
- (string? n))]
- [(var-expr id) (symbol? id)]
- [(let-expr x e1 e2 ) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(letrec-expr x e1 e2) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(if-expr eb et ef) (and (expr? eb)
- (expr? et)
- (expr? ef))]
- [(lambda-expr x e) (and (symbol? x)
- (expr? e))]
- [(app-expr ef ea) (and (expr? ef)
- (expr? ea))]
- [_ false]))
-
-;; Parsowanie (zacytowane wyrażenie -> składnia abstrakcyjna)
-(define (parse q)
- (cond
- [(number? q) (const q)]
- [(string? q) (const q)]
- [(eq? q 'true) (const true)]
- [(eq? q 'false) (const false)]
- [(eq? q 'null) (const null)]
- [(and (symbol? q)
- (not (keyword q)))
- (var-expr q)]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'let)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (let-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'letrec)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (letrec-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 4)
- (eq? (first q) 'if))
- (if-expr (parse (second q))
- (parse (third q))
- (parse (fourth q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'and))
- (desugar-and (map parse (cdr q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'or))
- (desugar-or (map parse (cdr q)))]
- [(and (list? q)
- (>= (length q) 2)
- (eq? (first q) 'cond))
- (parse-cond (cdr q))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'lambda)
- (list? (second q))
- (andmap symbol? (second q))
- (cons? (second q)))
- (desugar-lambda (second q) (parse (third q)))]
- [(and (list? q)
- (>= (length q) 2))
- (desugar-app (parse (first q)) (map parse (cdr q)))]
- [else (error "Unrecognized token:" q)]))
-
-(define (parse-cond qs)
- (match qs
- [(list (list 'else q))
- (parse q)]
-
- [(list (list q _))
- (error "Expected 'else' in last branch but found:" q)]
-
- [(cons (list qb qt) qs)
- (if-expr (parse qb) (parse qt) (parse-cond qs))]))
-
-(define (desugar-and es)
- (if (null? es)
- (const true)
- (if-expr (car es) (desugar-and (cdr es)) (const false))))
-
-(define (desugar-or es)
- (if (null? es)
- (const false)
- (if-expr (car es) (const true) (desugar-or (cdr es)))))
-
-(define (desugar-lambda xs e)
- (if (null? xs)
- e
- (lambda-expr (car xs) (desugar-lambda (cdr xs) e))))
-
-(define (desugar-app e es)
- (if (null? es)
- e
- (desugar-app (app-expr e (car es)) (cdr es))))
-
-;; Środowiska
-(struct blackhole ())
-(struct environ (xs))
-
-(define env-empty (environ null))
-(define (env-add x v env)
- (environ (cons (mcons x v) (environ-xs env))))
-(define (env-lookup x env)
- (define (assoc-lookup xs)
- (cond [(null? xs)
- (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (let ((v (mcdr (car xs))))
- (if (blackhole? v)
- (error "Jumped into blackhole at" x)
- v))]
- [else (assoc-lookup (cdr xs))]))
- (assoc-lookup (environ-xs env)))
-(define (env-update! x v env)
- (define (assoc-update xs)
- (cond [(null? xs) (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (set-mcdr! (car xs) v)]
- [else (assoc-update (cdr xs))]))
- (assoc-update (environ-xs env)))
-
-;; Domknięcia
-(struct clo (arg body env))
-
-;; Procedury wbudowane, gdzie
-;; proc — Racketowa procedura którą należy uruchomić
-;; args — lista dotychczas dostarczonych argumentów
-;; pnum — liczba brakujących argumentów (> 0)
-;; W ten sposób pozwalamy na częściową aplikację Racketowych procedur
-;; — zauważmy że zawsze znamy pnum, bo w naszym języku arność
-;; procedury jest ustalona z góry
-(struct builtin (proc args pnum) #:transparent)
-
-;; Pomocnicze konstruktory procedur unarnych i binarnych
-(define (builtin/1 p)
- (builtin (lambda (x) (return (p x))) null 1))
-(define (builtin/2 p)
- (builtin (lambda (x y) (return (p x y))) null 2))
-
-;; Procedury
-(define (proc? v)
- (or (and (clo? v)
- (symbol? (clo-arg v))
- (expr? (clo-body v))
- (environ? (clo-env v)))
- (and (builtin? v)
- (procedure? (builtin-proc v))
- (andmap value? (builtin-args v))
- (natural? (builtin-pnum v))
- (> (builtin-pnum v) 0))))
-
-;; Definicja typu wartości
-(define (value? v)
- (or (number? v)
- (boolean? v)
- (null? v)
- (string? v)
- (and (cons? v)
- (value? (car v))
- (value? (cdr v)))
- (proc? v)))
-
-;; Środowisko początkowe (przypisujące procedury wbudowane ich nazwom)
-
-(define start-env
- (foldl (lambda (p env) (env-add (first p) (second p) env))
- env-empty
- `((+ ,(builtin/2 +))
- (- ,(builtin/2 -))
- (* ,(builtin/2 *))
- (/ ,(builtin/2 /))
- (~ ,(builtin/1 -))
- (< ,(builtin/2 <))
- (> ,(builtin/2 >))
- (= ,(builtin/2 =))
- (<= ,(builtin/2 <=))
- (>= ,(builtin/2 >=))
- (not ,(builtin/1 not))
- (cons ,(builtin/2 cons))
- (car ,(builtin/1 car))
- (cdr ,(builtin/1 cdr))
- (pair? ,(builtin/1 cons?))
- (null? ,(builtin/1 null?))
- (boolean? ,(builtin/1 boolean?))
- (number? ,(builtin/1 number?))
- (procedure? ,(builtin/1 (lambda (x) (or (clo? x) (builtin? x)))))
- (string? ,(builtin/1 string?))
- (string-= ,(builtin/2 string=?))
- ;; and so on, and so on
- )))
-
-;; Efekt
-
-(define (effect-builtin/1 p)
- (builtin p null 1))
-(define (effect-builtin/2 p)
- (builtin p null 2))
-(define (effect-builtin/3 p)
- (builtin p null 3))
-
-
-(define effect-env
- (foldl (lambda (p env) (env-add (first p) (second p) env))
- start-env
- `((flip ,(effect-builtin/3 (lambda (p x y) (list (cons p x) (cons (- 1 p) y)))))
- (uniform ,(effect-builtin/1 (lambda (x) (let ((l (/ 1 (length x))))
- (map (lambda (x) (cons l x)) x)))))
- )))
-
-;; c to lista par (pstwo, wartość)
-;; k to funkcja która przyjmuje wartość i coś z nią robi sobie i zwraca listę par (pstwo, wartość)
-
-(define (bind c k)
- (append-map
- (lambda (x) (let ((pstwo (car x))
- (val (cdr x)))
- (map
- (lambda (x) (cons (* pstwo (car x)) (cdr x)))
- (k (cdr x)))))
- c))
-
-(define (return x) (list (cons 1 x)))
-
-;; Ewaluator
-(define (eval-env e env)
- (match e
- [(const n)
- (return n)]
-
- [(var-expr x)
- (return (env-lookup x env))]
-
- [(let-expr x e1 e2)
- (bind (eval-env e1 env) (lambda (v1)
- (eval-env e2 (env-add x v1 env))))]
-
- [(letrec-expr f ef eb)
- (let ((new-env (env-add f (blackhole) env)))
- (bind (eval-env ef new-env) (lambda (vf)
- (env-update! f vf new-env)
- (eval-env eb new-env))))]
-
- [(if-expr eb et ef)
- (bind (eval-env eb env) (lambda (vb)
- (match vb
- [#t (eval-env et env)]
- [#f (eval-env ef env)]
- [v (error "Not a boolean:" v)])))]
-
- [(lambda-expr x e)
- (return (clo x e env))]
-
- [(app-expr ef ea)
- (bind (eval-env ef env) (lambda (vf)
- (bind (eval-env ea env) (lambda (va)
- (match vf
- [(clo x e env)
- (eval-env e (env-add x va env))]
- [(builtin p args nm)
- (if (= nm 1)
- (apply p (reverse (cons va args)))
- (return (builtin p (cons va args) (- nm 1))))]
- [_ (error "Not a function:" vf)])))))]))
-
-(define (eval e)
- (eval-env e effect-env))
-
-
-;; Przykladowy program
-
-(define PROGRAM
- '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2)))
-
-
-;; REPL — interpreter interaktywny (read-eval-print loop)
-
-;; dodajemy składnię na wiązanie zmiennych "na poziomie interpretera"
-;; i komendę wyjścia "exit" ...
-(struct letrec-repl (id expr))
-(struct let-repl (id expr))
-(struct exit-repl ())
-
-;; ... a także rozszerzoną procedurę parsującą te dodatkowe komendy i
-;; prostą obsługę błędów
-(define (parse-repl q)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Parse error! ")
- (displayln (exn-message exn)))])
- (cond
- [(eq? q 'exit) (exit-repl)]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'let))
- (let-repl (second q) (parse (third q)))]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'letrec))
- (letrec-repl (second q) (parse (third q)))]
- [else (parse q)])))
-
-;; trochę zamieszania w procedurze eval-repl wynika z rudymentarnej
-;; obsługi błędów: nie chcemy żeby błąd w interpretowanym programie
-;; kończył działanie całego interpretera!
-(define (eval-repl c env continue)
- (define (eval-with-err e env)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Error! ")
- (displayln (exn-message exn)))])
- (eval-env e env)))
- (match c
- [(exit-repl)
- (void)]
-
- [(let-repl x e)
- (let ((v (eval-with-err e env)))
- (if (void? v)
- (continue env)
- (continue (env-add x v env))))]
-
- [(letrec-repl f e)
- (let* ((new-env (env-add f (blackhole) env))
- (v (eval-with-err e new-env)))
- (if (void? v)
- (continue env)
- (begin
- (env-update! f v new-env)
- (continue new-env))))]
-
- [_
- (let ((v (eval-with-err c env)))
- (unless (void? v)
- (displayln v))
- (continue env))]))
-
-;; I w końcu interaktywny interpreter
-(define (repl)
- (define (go env)
- (display "FUN > ")
- (let* ((q (read))
- (c (parse-repl q)))
- (if (void? c)
- (go env)
- (eval-repl c env go))))
- (displayln "Welcome to the FUN functional language interpreter!")
- (go start-env))
-
-
-(define prog '(if (flip 0.3 true false) "wygrana" "przegrana"))
-
-
-(define (norm xs)
- (define sum (lambda (xs) (foldl + 0 xs)))
- (define carlist (lambda (xs) (map car xs)))
- (define (iter xs res)
- (cond
- [(null? xs) res]
- [(member (cdar xs) (map cdr res)) (iter (cdr xs) res)]
- [else (let* ((cur (cdar xs))
- (pstwa (filter (lambda (x) (equal? (cdr x) cur)) xs)))
- (iter (cdr xs) (cons (cons (sum (carlist pstwa)) cur) res)))]))
- (iter xs null))
-
-
-(define DICE-MANY
- '(letrec [from-to (lambda (x n)
- (cons x
- (if (= x n)
- null
- (from-to (+ 1 x) n))))]
- (let [dice (lambda (x) (uniform (from-to 1 6)))]
- (letrec [dice-many (lambda (n) (if (= n 0)
- 0
- (+ (dice 0) (dice-many (- n 1)))))]
- (dice-many (dice 0)))))) \ No newline at end of file