Guest User

resource-bundle

a guest
Feb 8th, 2019
130
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (define fmt
  2.     (lambda (x . rest)
  3.         (if (and (not (null? rest)) (number? (head rest)) (= (head rest) 0))
  4.             (display x)
  5.             (begin
  6.                 (display x)
  7.                 (display "\n")
  8.             )
  9.         )
  10.     )
  11. )
  12. (define flatten
  13.     (lambda (l)
  14.         (flatMap l (lambda (x) x))
  15.     )
  16. )
  17. ; Def.:
  18. ; procedure flatmap(L,f)
  19. ;   if isList(L.head) then
  20. ;       return flatmap(L.head)
  21. ;   else
  22. ;   if length(L)>1 then
  23. ;       return f(L.head)::flatmap(L.tail)
  24. ;   else
  25. ;       return f(L.head)
  26.  
  27.  
  28. ;       Monadischer Typ "Liste"
  29. ; unit: T -> List[T]                        "tau": natürliche Transf.* der Liste
  30. ; map: (T->U),List[T] -> List[U]            map gehört zum Funktor* der Liste
  31. ; flatten: List[List[T]] -> List[T]         "mu": natürliche Transf. der Liste
  32. ;
  33. ; flatmap: (T->List[U]),List[T] -> List[U]
  34. ;
  35. ; * Funktor F: Struktur mit Abbildung von F[T] auf F[U] mittels einer Funktion T->U
  36. ; * natürliche Transformation: Abbildung von Funktor auf Funktor
  37. ;
  38. ;
  39. ;       Map, Flatten, FlatMap:
  40. ;           (Implementierung)
  41. ; flatMap(l: List[T],f: (T->U)) = flatMap(l,(t:T=>f(t)));
  42. ; map(l: List[T],f: (T->U)) = flatMap(l,(t:T=>unit(f(t))));
  43. ; flatten(l: List[List[T]]) = flatMap(l,(x:List[T]=>x));
  44. ;
  45. (define flatMap
  46.     (lambda (l f)
  47.         (if (and (list? l) (not (null? l)) (procedure? f))
  48.             (if (list? (car l))
  49.                 (flatMap (car l) f)
  50.                 (if (> (length l) 1)
  51.                     (cons (f (car l)) (flatMap (cdr l) f))
  52.                     (cons (f (car l)) ()) ;make a proper list
  53.                 )
  54.             )
  55.         )
  56.     )
  57. )
  58. (define reduce
  59.     (lambda (l f e)
  60.         (if (and (list? l) (not (null? l)) (procedure? f))
  61.             (if (list? (car l))
  62.                 (reduce (car l) f e)
  63.                 (if (> (length l) 1)
  64.                     (f (car l) (reduce (cdr l) f e))
  65.                     (f (car l) e)
  66.                 )
  67.             )
  68.         )
  69.     )
  70. )
  71. (define contains
  72.     ;;; get the index, if any, of an object in a list
  73.     (lambda (l0 x . i0)
  74.         (let (  (l (flatten l0)) (i (if (null? i0) 0 (car i0)))  )
  75.             (if (and (list? l) (not (null? l)) (or (number? x) (string? x) (symbol? x)))
  76.                 (begin
  77.                     ;(fmt i)
  78.                     (if (equal? (car l) x) ;equal? used (to enable string comparison)
  79.                         (+ i 1) ; 1-based
  80.                         (contains (cdr l) x (+ i 1))
  81.                     )
  82.                 )
  83.                 #f
  84.             )
  85.         )
  86.     )
  87. )
  88. ; elem: own implementation of list-ref
  89. (define elem
  90.     (lambda (l i)
  91.         (if (and (list? l) (>= (length l) 1))
  92.             (if (= i 1) ; makes the function 1-based
  93.                 (car l)
  94.                 (elem (cdr l) (- i 1))
  95.             )
  96.         )
  97.     )
  98. )
  99. (define id (lambda (x) x) )
  100. (define (make-list length value)
  101.     (if (< length 1)
  102.         '()
  103.         (cons value (make-list (- length 1) value))
  104.     )
  105. )
  106. (define write-out
  107.     (lambda (filename data)
  108.         (let ((out (open-output-file filename)) )
  109.             (write data out)
  110.             (close-output-port out)
  111.         )
  112.     )
  113. )
  114. (define read-in
  115.     (lambda (filename)
  116.         (let ((in (open-input-file filename)) )
  117.             (let cont ((d (read in))) ;cont is a 'named let'
  118.                 (if (eof-object? d)
  119.                     (begin
  120.                         (close-input-port in)
  121.                         '()
  122.                     )
  123.                     (cons d (cont (read in)))
  124.                 )
  125.             )  
  126.         )
  127.     )
  128. )
  129. ;           Named let
  130. ;   (let NAME ((VAR1 VAL1)...)
  131. ;       (EXP1)...
  132. ;   )
  133. ;
  134. ; - wie im unbenannten let, werden alle VARs an VALs gebunden (gültig im folgenden Block)
  135. ; - zusätzlich wird NAME im Block an eine Prozedur gebunden,
  136. ;       deren Argumente dann an die jeweilige VAR gebunden werden
  137. ; -> das ermöglicht eine innere Rekursion in einem Lambda
RAW Paste Data