From 4bbb1f4cd967fd3ccc91e68834ad9b4c5bc70d94 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 7 Sep 2010 16:15:02 -0500 Subject: [PATCH] Added a second column for the 2htdp teachpacks to the choose-a-teachpack dialog closes PR 11170 --- collects/lang/htdp-langs.rkt | 92 ++++++++++--------- .../english-string-constants.rkt | 3 +- collects/teachpack/2htdp/image.ss | 3 + 3 files changed, 55 insertions(+), 43 deletions(-) create mode 100644 collects/teachpack/2htdp/image.ss diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 9024bdb380..403b5dd567 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -678,45 +678,51 @@ data-class-names))))))))) (define (get-teachpack-from-user parent) - (define tp-dirs (list (collection-path "teachpack" "htdp") - (collection-path "teachpack" "2htdp"))) - (define columns 2) - (define tps (apply - append - (map (λ (tp-dir) - (filter - (λ (x) (file-exists? (build-path tp-dir x))) - (directory-list tp-dir))) - tp-dirs))) + (define tp-dirs (list "htdp" "2htdp")) + (define labels (list (string-constant teachpack-pre-installed/htdp) + (string-constant teachpack-pre-installed/2htdp))) + (define tpss (map (λ (tp-dir) + (let ([base (collection-path "teachpack" tp-dir)]) + (filter + (λ (x) (file-exists? (build-path base x))) + (directory-list base)))) + tp-dirs)) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) - (define pre-installed-tps (sort tps sort-order)) + (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss)) (define dlg (new dialog% [parent parent] [label (string-constant drscheme)])) (define hp (new horizontal-panel% [parent dlg])) (define answer #f) (define compiling? #f) - (define pre-installed-gb (new group-box-panel% - [label (string-constant teachpack-pre-installed)] - [parent hp])) + (define pre-installed-gbs (map (λ (tps label) + (new group-box-panel% + [label label] + [parent hp])) + tpss labels)) (define user-installed-gb (new group-box-panel% [label (string-constant teachpack-user-installed)] [parent hp])) - (define pre-installed-lb - (new list-box% - [label #f] - [choices (map path->string pre-installed-tps)] - [stretchable-height #t] - [min-height 300] - [min-width 200] - [callback - (λ (x evt) - (case (send evt get-event-type) - [(list-box-dclick) (selected pre-installed-lb)] - [else - (clear-selection user-installed-lb) - (update-button)]))] - [parent pre-installed-gb])) + (define pre-installed-lbs + (map (λ (pre-installed-gb pre-installed-tps) + (new list-box% + [label #f] + [choices (map path->string pre-installed-tps)] + [stretchable-height #t] + [min-height 300] + [min-width 200] + [callback + (λ (this evt) + (case (send evt get-event-type) + [(list-box-dclick) (selected this)] + [else + (for-each (λ (x) (unless (eq? x this) (clear-selection x))) + (cons user-installed-lb + pre-installed-lbs)) + (update-button)]))] + [parent pre-installed-gb])) + pre-installed-gbs + pre-installed-tpss)) (define user-installed-lb (new list-box% @@ -729,7 +735,8 @@ (case (send evt get-event-type) [(list-box-dclick) (selected user-installed-lb)] [else - (clear-selection pre-installed-lb) + (for ([pre-installed-lb (in-list pre-installed-lbs)]) + (clear-selection pre-installed-lb)) (update-button)]))] [parent user-installed-gb])) @@ -810,7 +817,8 @@ (define (post-compilation-gui-cleanup short-name) (update-user-installed-lb) - (clear-selection pre-installed-lb) + (for ([pre-installed-lb (in-list pre-installed-lbs)]) + (clear-selection pre-installed-lb)) (send user-installed-lb set-string-selection (path->string short-name))) (define (starting-compilation) @@ -838,7 +846,9 @@ (send ok-button enable (and (not compiling?) (or (pair? (send user-installed-lb get-selections)) - (pair? (send pre-installed-lb get-selections)))))) + (ormap (λ (pre-installed-lb) + (pair? (send pre-installed-lb get-selections))) + pre-installed-lbs))))) (define button-panel (new horizontal-panel% [parent dlg] @@ -856,17 +866,15 @@ (define (figure-out-answer) (cond - [(send pre-installed-lb get-selection) + [(ormap (λ (pre-installed-lb tp-dir) + (and (send pre-installed-lb get-selection) + (list tp-dir (send pre-installed-lb get-string (send pre-installed-lb get-selection))))) + pre-installed-lbs + tp-dirs) => - (λ (i) - (define f (send pre-installed-lb get-string i)) - (cond - [(file-exists? (build-path (collection-path "teachpack" "htdp") f)) - `(lib ,f "teachpack" "htdp")] - [(file-exists? (build-path (collection-path "teachpack" "2htdp") f)) - `(lib ,f "teachpack" "2htdp")] - [else (error 'figuer-out-answer "argh: ~a ~a" - (collection-path "teachpack" "htdp") f)]))] + (λ (pr) + (define-values (tp-dir f) (apply values pr)) + `(lib ,f "teachpack" ,tp-dir))] [(send user-installed-lb get-selection) => (λ (i) `(lib ,(send user-installed-lb get-string i) diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 23cb6e4a84..99c047fcc2 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -981,7 +981,8 @@ please adhere to these guidelines: ; ~a is filled with the teachpack's name; the message appears in the teachpack selection dialog when a user installs a new teachpack (compiling-teachpack "Compiling ~a teachpack ...") - (teachpack-pre-installed "Preinstalled Teachpacks") + (teachpack-pre-installed/htdp "Preinstalled HtDP Teachpacks") + (teachpack-pre-installed/2htdp "Preinstalled HtDP/2e Teachpacks") (teachpack-user-installed "User-installed Teachpacks") (add-teachpack-to-list... "Add Teachpack to List...") (teachpack-already-installed "A teachpack with the name '~a' has already been installed. Overwrite it?") diff --git a/collects/teachpack/2htdp/image.ss b/collects/teachpack/2htdp/image.ss new file mode 100644 index 0000000000..79b241c12e --- /dev/null +++ b/collects/teachpack/2htdp/image.ss @@ -0,0 +1,3 @@ +#lang racket/base +(require 2htdp/image) +(provide (all-from-out 2htdp/image))