Regroup a given sentence as per the provided pattern - CS61A - 2010 - Brian Harvey - Regroup problem

regroup.scm

; Problem statement: https://pastebin.com/SYfWadTU
; Running efficiency is not the aim of this program.
; The main aim was to make it work.

(define nil '())
(define true #t)
(define false #f)


; The evergreen accumulate function
(define (accumulate fn base args)
  (if (null? args)
      base
      (fn (car args) (accumulate fn base (cdr args)))))

; Get the element at x-th position of a list
; Domain: A list (any dimension), the position required
; Range: Element at x if x is valid, else empty list
; Index starts at 1, not 0
(define (ele-at-x ls x)
  (cond ((null? ls) '())
        ((= x 1) (car ls))
        (else (ele-at-x (cdr ls) (- x 1)))))


; Takes a list of numbers
; Returns a new list with the differences between adjacent elements
; => (list-of-diffs '(1 3 5 7)) 
;    '(2 2 2)
(define (list-of-diffs ls)
  (if (null? (cdr ls))
      nil
      (cons (- (cadr ls) (car ls)) (list-of-diffs (cdr ls)))))


; Takes a list
; Returns true if the list is empty
;         or if all the members of the list are equal
(define (all-members-equal? ls)
  (or (null? ls) (null? (remove-ele ls (car ls)))))


; Domain: 1-D list of numbers
; Range: Empty list: false
;        List which is not an arithmetic progression: false
;        List which is an arithmetic progression: the constant difference value
;        Progression with negative difference is not considered a progression: Returns false
(define (is-sequence? ls)
  (define (helper seq)
    (cond ((null? seq) false)
          ((null? (cdr seq)) (car seq))
          (else
            (let ((diffs-ls (list-of-diffs seq)))
              (if (and (all-members-equal? diffs-ls) (> (car diffs-ls) 0))
                  (car diffs-ls)
                  false)))))
  (helper (remove-ele ls '...)))


; Domain: A list (ls) 
;         The element to remove (x)
; Range: New list with all instances of x removed from ls
(define (remove-ele ls x)
  (cond ((null? ls) nil)
        ((equal? (car ls) x) (remove-ele (cdr ls) x))
        (else (cons (car ls) (remove-ele (cdr ls) x)))))


; Returns a function that takes a list as an argument
; and returns true if x is in that list.
(define (contains? x)
  (lambda (ls)
    (cond ((null? ls) false)
          ((equal? x (car ls)) true)
          (else ((contains? x) (cdr ls))))))

(define has-ellipsis? (contains? '...))


; Strip the front of a list by i-1 positions
; Domain: i >= 1
; If i = 1, return the list as it is
(define (move-start-ptr ls i)
  (cond ((null? ls) nil)
        ((= i 1) ls)
        (else (move-start-ptr (cdr ls) (- i 1)))))


; CDR through a list 'n' times
(define (cdr-times ls n)
  (move-start-ptr ls (+ n 1)))


; Get the max number in the pattern
(define (max-in-pattern ls)
  (accumulate max 0 (remove-ele ls '...)))


; Fill a 1-D pattern with a sentence
(define (fill-pattern pattern sntnc)
  (cond ((< (length sntnc) (max-in-pattern pattern)) nil)
        ((has-ellipsis? pattern) (fill-cont-pattern pattern sntnc))
        (else (fill-ltd-pattern pattern sntnc))))


; Create a sentence as per the pattern
(define (fill-ltd-pattern pattern sntnc)
  (map
    (lambda (index)
      (ele-at-x sntnc index))
    pattern))


; Create a sentence as per the pattern ending with ellipsis
(define (fill-cont-pattern pattern sntnc)
  (define (every-nth ls n)
    (define (every-nth-recur ls index)
      (cond ((null? ls) nil)
            ((= 0 (remainder index n))
              (cons (car ls) (every-nth-recur (cdr ls) (+ index 1))))
            (else
              (every-nth-recur (cdr ls) (+ index 1)))))
    (every-nth-recur ls 0))
  (let ((diff (is-sequence? pattern)))
    (if diff
        (every-nth (move-start-ptr sntnc (car pattern)) diff)
        (let* ((san-pattern (remove-ele pattern '...))
              (pattern-len (length san-pattern)))
          (define (non-seq-helper sent)
            (if (< (length sent) pattern-len)
                nil
                (append (fill-ltd-pattern san-pattern sent)
                        (non-seq-helper (cdr-times sent pattern-len)))))
          (non-seq-helper sntnc)))))


; The main function
; Takes a pattern in the form of '((1 2 ...) (2 3 ...) ...)
;   (see problem statement for examples of patterns)
; Returns a function which takes a list of words as an argument
;   and format the list as per the given pattern
; It is not necessary to have a list of words; any list will work.
; Example:
; >> (define split (regroup '((1 3 ...) (2 4 ...))))
; >> (split '(the rain in spain stays mainly on the plain))
; Out: ((the in stays on plain) (rain spain mainly the))
(define (regroup pattern)
  (define (next-sent sent)
    (if (> (length pattern) 2)
        (let ((diff (- (caadr pattern) (caar pattern))))
          (cdr-times sent diff))
        (cdr-times sent (accumulate + 0 (remove-ele (car pattern) '...)))))
  (define (patternize sntnc)
    (cond ((null? sntnc) nil)
          ((number? (car pattern))
            (fill-pattern pattern sntnc))
          ((has-ellipsis? pattern)
            (let ((sub-ls (fill-pattern (car pattern) sntnc)))
              (if (null? sub-ls)
                  nil
                  (cons sub-ls (patternize (next-sent sntnc))))))
          (else
            (map (lambda (ptrn)
                   (fill-pattern ptrn sntnc))
                 pattern))))
  patternize)