Structure And Interpretation of Computer Programs Ex2_74 - scheme

I'm trying to tag a list so that the file1 variable out like the following in Racket:
(Div1 ((Sam Parnell 100) (Tom Edward 1000) (Rob Hanbury 500) (Andy Springwood 500)))
however I am getting:
((Sam Parnell 100) (Tom Edward 1000) (Rob Hanbury 500) (Andy Springwood 500))
I am using "tag" internally in my package to tag a series of records using the make-file procedure. It should follow the evaluation model set out in section 1.1.3 I think, but it feels like it isn't and this may be to do with the fact that I have defined make-file to take an arbitrary number of arguments which may effect the evaluation model in ways I haven't yet understood. I've also attempted to debug this in Racket to no avail as it skips how it is evaluated as I step through, so I'm stuck. If anyone could help, it would be greatly appreciated.
#lang sicp
(#%require (only racket/base error))
(#%require (only racket/base make-hash))
(#%require (only racket/base hash-set!))
(#%require (only racket/base hash-ref))
; table set up
(define *op-table* (make-hash))
(define (put op type proc)
(hash-set! *op-table* (list op type) proc))
(define (get op type)
(hash-ref *op-table* (list op type) '()))
; data tagging set up
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERERIC"
(list op type-tags))))))
(define (install-Div1-Package)
(define (get-name record)
(car record))
(define (get-address record)
(cadr record))
(define (get-salary record)
(caddr record))
(define (make-record name address salary)
(list name address salary))
(define (get-record key file)
(cond ((null? file) (error "Employee not in file"))
((eq? key (get-name (car file)))
(car file))
(else (get-record key (cdr file)))))
(define (make-file . records)
records)
;interface to the rest of the system
(define (tag x) (attach-tag 'Div1 x))
(put 'get-name '(Div1) get-name)
(put 'get-address '(Div1) get-address)
(put 'get-salary '(Div1) get-salary)
(put 'make-record 'Div1
(lambda (name address salary)
(make-record name address salary)))
(put 'get-record '(Div1) get-record)
(put 'make-file 'Div1
(lambda args
(tag (make-file args)))))
(install-Div1-Package)
(define (make-record name address salary)
((get 'make-record 'Div1) name address salary))
(define record1 (make-record 'Sam 'Parnell 100))
(define record2 (make-record 'Tom 'Edward 1000))
(define record3 (make-record 'Rob 'Hanbury 500))
(define record4 (make-record 'Andy 'Springwood 500))
record1
(define (make-file . records)
(get 'make-file 'Div1) records)
(define file1 (make-file record1 record2 record3 record4))
file1

You forgot to actually call the make-file procedure:
(define (make-file . records)
(get 'make-file 'Div1) ; retrieves the procedure, does nothing with it
records) ; return the same input list
Also, because you want to take an arbitrary number of arguments you need to apply it; this should work:
(define (make-file . records)
(apply (get 'make-file 'Div1) records))

Related

Why do I get "application: not a procedure" with this for loop in Racket?

The following code reads a csv file and based on its content generates a Prolog program:
#!/usr/bin/env racket
#lang racket/base
(define (overwrite-s-to-f fname s); Will create fname and write overwriting the previous content.
(with-output-to-file #:exists 'truncate fname (lambda () (displayln s))))
(define (c-o-a-line-to-f fname s); Will append a string to fname or create it if does not exist. Appends a new line.
(with-output-to-file #:exists 'append fname (lambda () (displayln s))));
(define fname "women.csv")
(define pl-fname "females-by-Racket.pl")
(require racket/file)
(define content (file->lines fname))
(define disc-line (string-append ":-discontiguous(" (string-replace (car content) "Name," "") ").\n"))
(overwrite-s-to-f pl-fname disc-line)
(define list-of-verbs (string-split (string-replace (car content) "Name," "") ","))
(require racket/string racket/system)
(for ((row content));content is a list of strings
(let ((list-of-cs (string-split row ",")))
(when (equal? (car (cdr list-of-cs)) "+")
(displayln row)(let ((cmd (string-append "awesome("(car list-of-cs)").")))(c-o-a-line-to-f pl-fname cmd)(displayln cmd)))
(when (equal? (car (cdr (cdr list-of-cs))) "+")(displayln row)(let ((cmd (string-append "and_intelligent("(car list-of-cs)").")))
(c-o-a-line-to-f pl-fname cmd)(displayln cmd))))); TODO: when for each columns 2-last of women.csv
The content of women.csv:
Name,awesome,and_intelligent,performed_once,extreme1,extreme2,extreme3,extreme4,donkey_thing,dark_eyes,pigmented_face,pigmented_genitals,bleached,had_no_surgeries,has_augmented_breasts
adriana_chechik,+,,,+,?,+,+,,-,,,,,
alysa_gap,+,,,,?,+,+,,-,,,,,
anna_de_ville,+,,,,,+,+,,+,-,+,-,-,
aurora_jolie,+,+,,,,,,,+,+,+,,+,
autumn_falls,,,,,,,,,+,+,-,+,+,
casey_calvert,+,,,,,,,,+,+,+,,,
dahlia_sky,+,,,,,,+,,,,,,,
dominica_lito,+,,,,,,+,,,,,,,
ella_knox,,,,,,,,,+,+,+,,+,
isabella_clark,+,,,,,,+,,,,,,,
jade_kush,,,,,,,,,+,+,,,+,
juelz_ventura,+,,,,,+,,,-,-,,,-,+
kapri_styles,,,,,,,,,+,,+,,,
kristina_milan,,,,,,,,,+,+,,,+,
kylie_sinner,+,+,,,,,,,+,,,,-,
leigh_raven,+,,,,,+,,,+,+,,,,
maserati,,,,,,,,,+,+,,,+,
miosotis,,,,,,,,,+,+,,,+,
scarlett_bloom,,,,,,,,,+,+,+,,-,
sheena_shaw,,,,,,,,,-,,+,,-,
sofia_rose,,,,,,,,,+,,,,+,
teanna_trump,+,,,,,,,,+,,+,,,
veronica_avluv,+,,,,,,+,,,,,,,
yudi_pineda,+,,,,,,,,+,+,,,,
females-by-Racket.pl is to look like so:
:-discontiguous(awesome,and_intelligent,performed_once,extreme1,extreme2,extreme3,extreme4,donkey_thing,dark_eyes,pigmented_face,pigmented_genitals,bleached,had_no_surgeries,has_augmented_breasts).
awesome(adriana_chechik).
awesome(alysa_gap).
awesome(anna_de_ville).
awesome(aurora_jolie).
and_intelligent(aurora_jolie).
awesome(casey_calvert).
awesome(dahlia_sky).
awesome(dominica_lito).
awesome(isabella_clark).
awesome(juelz_ventura).
awesome(kylie_sinner).
and_intelligent(kylie_sinner).
awesome(leigh_raven).
awesome(teanna_trump).
awesome(veronica_avluv).
awesome(yudi_pineda).
but with more predicates (up to n-1 for each woman where n is the number of columns in women.csv)
The names of the columns or the numbers thereof in women.csv are likely to be frequently changed.
That is partly why I wish to avoid manually coding for every when. The other concerns are the sheer amount of the lines to code (15 whens for each column) and the risk of error/typo.
Is it doable to loop through every cell in list-of-cs in such way that it is taken from list-of-verbs?
I've tried this but to no avail (the comment show the error message that I got):
(for ((row content))
(let ((list-of-cs (cdr (string-split row ","))))
(for ((cell list-of-cs))
; application: not a procedure; expected a procedure
; that can be applied to arguments
(set! list-of-verbs (cdr (list-of-verbs)))
(let ((verb (car list-of-verbs)))
(when (equal? cell "+")
(displayln row)
(let ((cmd (string-append verb "(" (car row) ").")))
(c-o-a-line-to-f pl-fname cmd)))
))))
named let is a useful form to be familiar with:
#lang scheme
(define (csv->attributes rows) ;; ListOfString -> ListOfString
;; produce "column-header(row-name)" for "+" entries in csv (see example)
(let ([fields (string-split (car rows) ",")])
(let next-row ([rows (cdr rows)] [result (list)])
(cond
[(null? rows) (reverse result) ]
[else
(let* ([cells (string-split (car rows) ",")]
[name (car cells)])
(let next-cell ([cells (cdr cells)] [fields (cdr fields)] [result result])
(cond
[(null? cells) (next-row (cdr rows) result) ]
[else (next-cell
(cdr cells) (cdr fields)
(if (string=? (car cells) "+")
(cons (string-append (car fields) "(" name ")") result)
result)) ]))) ]))))
(define trio '("Name,fast,slow,sidles"
"Achilles,+,,"
"Tortoise,,+,"
"Crab,,+,+"))
Welcome to DrRacket, version 8.5 [cs].
Language: scheme, with debugging.
> (csv->attributes trio)
("fast(Achilles)" "slow(Tortoise)" "slow(Crab)" "sidles(Crab)")
>

Unusual Scheme `let` binding, what is `f`?

In "The Scheme Programming Language 4th Edition" section 3.3 Continuations the following example is given:
(define product
(lambda (ls)
(call/cc
(lambda (break)
(let f ([ls ls])
(cond
[(null? ls) 1]
[(= (car ls) 0) (break 0)]
[else (* (car ls) (f (cdr ls)))]))))))
I can confirm it works in chezscheme as written:
> (product '(1 2 3 4 5))
120
What is 'f' in the above let? Why is the given ls being assigned to itself? It doesn't seem to match what I understand about (let ...) as described in 4.4 local binding:
syntax: (let ((var expr) ...) body1 body2 ...)
If 'f' is being defined here I would expect it inside parenthesis/square brackets:
(let ([f some-value]) ...)
This is 'named let', and it's a syntactic convenience.
(let f ([x y] ...)
...
(f ...)
...)
is more-or-less equivalent to
(letrec ([f (λ (x ...)
...
(f ...)
...)])
(f y ...))
or, in suitable contexts, to a local define followed by a call:
(define (outer ...)
(let inner ([x y] ...)
...
(inner ...)
...))
is more-or-less equivalent to
(define (outer ...)
(define (inner x ...)
...
(inner ...)
...)
(inner y ...))
The nice thing about named let is that it puts the definition and the initial call of the local function in the same place.
Cavemen like me who use CL sometimes use macros like binding, below, to implement this (note this is not production code: all its error messages are obscure jokes):
(defmacro binding (name/bindings &body bindings/decls/forms)
;; let / named let
(typecase name/bindings
(list
`(let ,name/bindings ,#bindings/decls/forms))
(symbol
(unless (not (null bindings/decls/forms))
(error "a syntax"))
(destructuring-bind (bindings . decls/forms) bindings/decls/forms
(unless (listp bindings)
(error "another syntax"))
(unless (listp decls/forms)
(error "yet another syntax"))
(multiple-value-bind (args inits)
(loop for binding in bindings
do (unless (and (listp binding)
(= (length binding) 2)
(symbolp (first binding)))
(error "a more subtle syntax"))
collect (first binding) into args
collect (second binding) into inits
finally (return (values args inits)))
`(labels ((,name/bindings ,args
,#decls/forms))
(,name/bindings ,#inits)))))
(t
(error "yet a different syntax"))))
f is bound to a procedure that has the body of let as a body and ls as a parameter.
http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_sec_11.16
Think of this procedure:
(define (sum lst)
(define (helper lst acc)
(if (null? lst)
acc
(helper (cdr lst)
(+ (car lst) acc))))
(helper lst 0))
(sum '(1 2 3)) ; ==> 6
We can use named let instead of defining a local procedure and then use it like this:
(define (sum lst-arg)
(let helper ((lst lst-arg) (acc 0))
(if (null? lst)
acc
(helper (cdr lst)
(+ (car lst) acc)))))
Those are the exact same code with the exception of some duplicate naming situations. lst-arg can have the same name lst and it is never the same as lst inside the let.
Named let is easy to grasp. call/ccusually takes some maturing. I didn't get call/cc before I started creating my own implementations.

Scheme Function Maker

I've been working on this procedure in Scheme (specifically Pretty Big) and I've hit a brick wall. What I'm trying to do is create a procedure that can create other procedures or functions. For the most part I think I'm on the correct track.
(define (function-maker function-specs)
(let* [(specs (map cdr function-specs))
(name (caar specs))
(args (cadr function-specs))
(body (cdr(cdr function-specs)))]
(eval(list 'define name
(list 'lambda args body)))))
Current Output:
Above is the current output and I'll explain to the best of my knowledge what is happening. The input takes in three arguments essentially. A name, to name the function. Arguments for the function and finally the body of the function.
The three arguments are then listed together and then it's supposed to create a new function. The picture above shows the error that I'm reaching. Thanks for the help!
To see what's happening, get rid of the eval and examine the list:
(define (function-maker function-specs)
(let* [(specs (map cdr function-specs))
(name (caar specs))
(args (cadr function-specs))
(body (cdr(cdr function-specs)))]
(list 'define name
(list 'lambda args body))))
> (function-maker '((name: add5) (x) (+ x 5)))
'(define add5 (lambda (x) ((+ x 5))))
As you can see, there are too many parentheses in the body, so you're attempting to use the resulting number as a procedure.
You want
(body (car (cdr (cdr function-specs))))
or
(body (caddr function-specs))

How to print user-defined environment in scheme?

In general I want write code in REPL and sometimes save all defined by myself symbols to file.
For example - after typing in REPL:
]=> (define (square x) (* x x))
]=> (define sizes '(5 10 15))
I need to call something to receive a list of previously defined objects.
In this case it can be represented in this way:
]=> (define get-user-defined-environment
(list (list 'sizes sizes) (list 'square square)))
To be able then call something like this:
]=> (map
(lambda (lst) (begin
(display "(define ")
(pp (first lst))
(pp (second lst))
(display ")\n\n")))
get-user-defined-environment)
(define sizes
(5 10 15)
)
(define square
(named-lambda (square x)
(* x x))
)
And, maybe, save output to file somehow.
So, what could be this get-user-defined-environment ?
There isn't something in standard Scheme that lets you record the environment. You can however define your own define-like syntax that does it for you.
> (define *env* '())
> (define-syntax def&rec
(syntax-rules ()
((_ name init)
(define name
(let ((value init))
(set! *env* (cons (cons 'name value) *env*))
value)))))
> (def&rec foo 1)
> (def&rec bar (lambda (x) x))
> *env*
((bar . #<procedure value>) (foo . 1))
If you intend to write this to a file, like with the expectation of reading it back in, you will want to record the init form, not value in the syntax above. Here is another syntactic form to record the init:
> (define-syntax def&rec2
(syntax-rules ()
((_ name init)
(define name
(let ((value init))
(set! *env* (cons (list 'name value 'init) *env*))
value)))))
> (def&rec2 equal-to (lambda (x) (lambda (y) (equal? x y))))
> *env*
((equal-to #<procedure value>
(lambda (x) (lambda (y) (equal? x y))))
(bar . #<procedure value>) (foo . 1))
Thanks to uselpa pointed to How can find all functions and bounded symbols in an "environment"
(environment-bound-names (the-environment)) - returns a list of user-defined names.
Then (environment-lookup (the-environment) name) - returns value of a name in current environment.
Here is the way:
]=> (define (p1 name env) (begin (display "(define ") (pp name) (pp (environment-lookup env name)) (display ")\n\n")))
]=> (define (p2 lst env) (for-each (lambda (name) (p1 name env)) lst))
]=> (p2 (reverse (environment-bound-names (the-environment))) (the-environment))
(define p1
(named-lambda (p1 name env)
(display "(define ")
(pp name)
(pp (environment-lookup env name))
(display ")\n\n"))
)
(define p2
(named-lambda (p2 lst env)
(for-each (lambda (name) (p1 name env)) lst))
)

Scheme Formatting Help

I've been working on a project for school that takes functions from a class file and turns them into object/classes. The assignment is all about object oriented programming in scheme.
My problem however is that my code doesn't format right.
The output it gives me whenever I give it a file to pass in wraps the methods of the class in a list, making it so that the class never really gets declared. I can't for the life of me figure out how to get the parenthesis wrapping the method list to remove.
I would really appreciate any help.
Below is the output, the class file and the code,.
(define pointInstance
(let ((myx 1) (myy 2))
(lambda msg
(cond
(((eq? (car msg) getx) myx)
((eq? (car msg) gety) myy)
((eq? (car msg) setx) (set! myx x))
((eq? (car msg) show) (begin (display "[") (display myx) (display ",") (display myy) (display "]"))))))))
If you look at just after the cond you'll see how all those eq statements are contained in a list. I can't get this to work right unless they're not wrapped by that top level list.
;;;; PART1 --- A super-easy set of classes. Just models points and lines. Tests all of >the
;; basics of class behavior without touching on anything particularly complex.
(class pointInstance (parent:) (constructor_args:)
(ivars: (myx 1) (myy 2))
(methods:
(getx () myx)
(gety () myy)
(setx (x) (set! myx x))
(show () (begin (display "[") (display myx) (display ",") (display myy) (display "]")))
))
(require (lib "trace.ss"))
;; Continue reading until you hit the end of the file, all the while
;; building a list with the contents
(define load-file
(lambda (port)
(let ((rec (read port)))
(if (eof-object? rec)
'()
(cons rec (load-file port))))))
;; Open a port based on a file name using open-input-file
(define (load fname)
(let ((fport (open-input-file fname)))
(load-file fport)))
;(define lis (load "C:\\Users\\Logan\\Desktop\\simpletest.txt"))
;(define lis (load "C:\\Users\\Logan\\Desktop\\complextest.txt"))
(define lis (load "C:\\Users\\Logan\\Desktop\\pointinstance.txt"))
;(display (cdaddr (cdddar lis)))
(define makeMethodList
(lambda (listToMake retList)
;(display listToMake)
(cond
[(null? listToMake)
retList
;(display "The list passed in to parse was null")
]
[else
(makeMethodList (cdr listToMake) (append retList (list (getMethodLine listToMake))))
]
)
))
;(trace makeMethodList)
;this works provided you just pass in the function line
(define getMethodLine
(lambda (functionList)
`((eq? (car msg) ,(caar functionList)) ,(caddar functionList))))
(define load-classes
(lambda paramList
(cond
[(null? paramList) (display "Your parameters are null, man.")]
[(null? (car paramList))(display "Done creating class definitions.")]
[(not (null? (car paramList)))
(begin
(let* ((className (cadaar paramList))
(classInstanceVars (cdaddr (cddaar paramList)))
(classMethodList (cdr (cadddr (cddaar paramList))))
(desiredMethodList (makeMethodList classMethodList '()))
)
;(display "Classname: ")
;(display className)
;(newline)(newline)
;(display "Class Instance Vars: ")
;(display classInstanceVars)
;(newline)(newline)
;(display "Class Method List: ")
;(display classMethodList)
;(newline)
;(display "Desired Method List: ")
;(display desiredMethodList))
;(newline)(newline)
;----------------------------------------------------
;do not delete the below code!`
`(define ,className
(let ,classInstanceVars
(lambda msg
;return the function list here
(cond ,(makeMethodList classMethodList '())))
))
;---------------------------------------------------
))]
)
))
(load-classes lis)
;(load-classes lis)
;(load-classes-helper lis)
;(load-classes "simpletest.txt")
;(load-classes "complextest.txt")
;method list
;(display (cdr (cadddr (cddaar <class>))))
You have too many opening parenthesis in the 1st clause of the cond.
IE:
(((eq? (car msg) getx) myx)
^
Updated:
Are you looking for this?
(cond ,#(makeMethodList classMethodList '())
^^
Or you can do:
(cond . ,(makeMethodList classMethodList '())

Resources