Add typed SSD emulator self-test support
ober
606d8eaf5a74c23bb33af97be321da6f9139f7b3
new file mode 100644 --- /dev/null +++ b/templates/ssd-review-parts/SsdSelfTestFixture.ss @@ -0,0 +1,508 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/sfb/ssdreview/SsdSelfTestFixture.kt" + (kotlin-imports + (android graphics Bitmap) + (android graphics Bitmap Config) + (android graphics Canvas) + (android graphics Color) + (android graphics Paint) + (android graphics Paint Style) + (android graphics Typeface) + (org json JSONArray) + (org json JSONObject)) + (typed-library (com sfb ssdreview) + (export make-SsdSelfTestFixture SsdSelfTestFixture? + SsdSelfTestFixture-kind SsdSelfTestFixture-pdfName + SsdSelfTestFixture-pdfSha1 SsdSelfTestFixture-pageIndex + SsdSelfTestFixture-pageCount SsdSelfTestFixture-sourceUri + SsdSelfTestFixture-bitmap SsdSelfTestFixture-session + SsdSelfTestFixture-selectedGroupId SsdSelfTestFixture-status + SsdSelfTestFixture-stage makeReviewSelfTestFixture + makeOcrSelfTestFixture makeServerLabelsSelfTestFixture + makeSelfTestFixture selfTestCell selfTestGroup + selfTestProposalJson drawSelfTestOcrPage) + (type Bitmap) (type Config) (type Canvas) (type Paint) + (type Style) (type Typeface) (type JSONArray) (type JSONObject) + (type Int32) (type Float32) (type FloatArray) + (val SSD_SELF_TEST_DPI : Int32 (int32 144) + (modifiers private const)) + (record SsdSelfTestFixture + ((kind : String) (pdfName : String) (pdfSha1 : String) + (pageIndex : Int32) (pageCount : Int32) (sourceUri : String) + (bitmap : Bitmap) (session : SsdSession) + (selectedGroupId : (Nullable String)) (status : String) + (stage : String))) + (extern + (ssdSelfTestBitmapConfig) : Config + (kotlin-value Bitmap Config ARGB_8888)) + (extern + (ssdSelfTestCreateBitmap + (width : Int32) + (height : Int32) + (config : Config)) + : Bitmap + (kotlin-call Bitmap createBitmap)) + (extern + (ssdSelfTestEraseBitmap (bitmap : Bitmap) (color : Int32)) + : Unit + (kotlin-member-call eraseColor)) + (extern + (ssdSelfTestColorWhite) : Int32 + (kotlin-value Color WHITE)) + (extern + (ssdSelfTestColorBlack) : Int32 + (kotlin-value Color BLACK)) + (extern + (ssdSelfTestColorRgb (red : Int32) (green : Int32) (blue : Int32)) + : Int32 + (kotlin-call Color rgb)) + (extern + (ssdSelfTestCanvas (bitmap : Bitmap)) + : Canvas + (kotlin-call Canvas)) + (extern + (ssdSelfTestPaint (flags : Int32)) + : Paint + (kotlin-call Paint)) + (extern + (ssdSelfTestPaintAntiAliasFlag) : Int32 + (kotlin-value Paint ANTI_ALIAS_FLAG)) + (extern + (ssdSelfTestPaintFill) : Style + (kotlin-value Paint Style FILL)) + (extern + (ssdSelfTestPaintStroke) : Style + (kotlin-value Paint Style STROKE)) + (extern + (ssdSelfTestPaintStyleSet (paint : Paint) (style : Style)) + : Unit + (kotlin-member-set style)) + (extern + (ssdSelfTestPaintColorSet (paint : Paint) (color : Int32)) + : Unit + (kotlin-member-set color)) + (extern + (ssdSelfTestPaintStrokeWidthSet + (paint : Paint) + (width : Float32)) + : Unit + (kotlin-member-set strokeWidth)) + (extern + (ssdSelfTestPaintTextSizeSet (paint : Paint) (size : Float32)) + : Unit + (kotlin-member-set textSize)) + (extern + (ssdSelfTestDefaultBold) : Typeface + (kotlin-value Typeface DEFAULT_BOLD)) + (extern + (ssdSelfTestPaintTypefaceSet + (paint : Paint) + (typeface : Typeface)) + : Unit + (kotlin-member-set typeface)) + (extern + (ssdSelfTestDrawRect + (canvas : Canvas) + (left : Float32) + (top : Float32) + (right : Float32) + (bottom : Float32) + (paint : Paint)) + : Unit + (kotlin-member-call drawRect)) + (extern + (ssdSelfTestDrawText + (canvas : Canvas) + (text : String) + (x : Float32) + (y : Float32) + (paint : Paint)) + : Unit + (kotlin-member-call drawText)) + (def (ssdSelfTestBlankBitmap) + : Bitmap + (let ([bitmap + (ssdSelfTestCreateBitmap + (int32 900) + (int32 1200) + (ssdSelfTestBitmapConfig))]) + (begin + (ssdSelfTestEraseBitmap bitmap (ssdSelfTestColorWhite)) + bitmap))) + (def (selfTestCell (id : String) (x : Float32) (y : Float32)) + : SsdCell + (make-SsdCell + id x y (float32 28.0) (float32 28.0) "self-test")) + (def (selfTestGroup + (id : String) + (label : String) + (boxTypeId : String) + (status : String) + (cellIds : (MutableList String))) + : SsdGroup + (make-SsdGroup + id + label + boxTypeId + status + (int32 0) + (float-array + (float32 0.0) + (float32 0.0) + (float32 0.0) + (float32 0.0)) + cellIds + "" + "Self-test fixture")) + (def (ssdSelfTestIds1 (a : String)) + : (MutableList String) + (let ([out (mutable-list-empty String)]) + (begin (mutable-list-add! out a) out))) + (def (ssdSelfTestIds2 (a : String) (b : String)) + : (MutableList String) + (let ([out (ssdSelfTestIds1 a)]) + (begin (mutable-list-add! out b) out))) + (def (ssdSelfTestIds4 + (a : String) + (b : String) + (c : String) + (d : String)) + : (MutableList String) + (let ([out (ssdSelfTestIds2 a b)]) + (begin + (mutable-list-add! out c) + (mutable-list-add! out d) + out))) + (def (ssdSelfTestReviewCells) + : (MutableList SsdCell) + (let ([out (mutable-list-empty SsdCell)]) + (begin + (mutable-list-add! out (selfTestCell "c0001" (float32 170.0) (float32 120.0))) + (mutable-list-add! out (selfTestCell "c0002" (float32 205.0) (float32 120.0))) + (mutable-list-add! out (selfTestCell "c0003" (float32 240.0) (float32 120.0))) + (mutable-list-add! out (selfTestCell "c0004" (float32 275.0) (float32 120.0))) + (mutable-list-add! out (selfTestCell "c0005" (float32 430.0) (float32 390.0))) + (mutable-list-add! out (selfTestCell "c0006" (float32 430.0) (float32 425.0))) + (mutable-list-add! out (selfTestCell "c0007" (float32 610.0) (float32 410.0))) + (mutable-list-add! out (selfTestCell "c0008" (float32 645.0) (float32 410.0))) + (mutable-list-add! out (selfTestCell "c0009" (float32 330.0) (float32 720.0))) + (mutable-list-add! out (selfTestCell "c0010" (float32 365.0) (float32 720.0))) + out))) + (def (ssdSelfTestReviewGroups) + : (MutableList SsdGroup) + (let ([out (mutable-list-empty SsdGroup)]) + (begin + (mutable-list-add! out + (selfTestGroup + "g0001" "shield-1?" "26" "candidate" + (ssdSelfTestIds4 "c0001" "c0002" "c0003" "c0004"))) + (mutable-list-add! out + (selfTestGroup + "g0002" "excess damage?" "13" "candidate" + (ssdSelfTestIds2 "c0005" "c0006"))) + (mutable-list-add! out + (selfTestGroup + "g0003" "phaser-1" "33" "reviewed" + (ssdSelfTestIds2 "c0007" "c0008"))) + (mutable-list-add! out + (selfTestGroup + "g0004" "battery?" "18" "candidate" + (ssdSelfTestIds2 "c0009" "c0010"))) + (mutable-list-add! out + (selfTestGroup + "g0005" "shield-1?" "26" "candidate" + (ssdSelfTestIds4 "c0001" "c0002" "c0003" "c0004"))) + out))) + (def (ssdSelfTestRecomputeGroups (session : SsdSession)) + : Unit + (forEachSsdSessionGroup + session + (lambda ((group : SsdGroup)) + (ssdSessionRecomputeGroup session group)))) + (def (makeReviewSelfTestFixture) + : SsdSelfTestFixture + (let ([bitmap (ssdSelfTestBlankBitmap)]) + (let ([session + (make-SsdSession + "ssd-selftest-session" + "ssd-selftest-p0001-d144" + "SFB SSD Self Test" + "selftest://ssd-review" + (int32 1) + (int32 1) + SSD_SELF_TEST_DPI + (int32 900) + (int32 1200) + (ssdSelfTestReviewCells) + (ssdSelfTestReviewGroups) + (mutable-list-empty OcrWord) + (mutable-list-empty SsdGroup) + (nullable-none FloatArray))]) + (begin + (ssdSelfTestRecomputeGroups session) + (make-SsdSelfTestFixture + "review" + "SFB SSD Self Test" + "ssdselftestfixture" + (int32 0) + (int32 1) + "selftest://ssd-review" + bitmap + session + (nullable-some "g0001") + "SELFTEST_READY" + "loaded"))))) + (def (ssdSelfTestDrawCell + (canvas : Canvas) + (fill : Paint) + (border : Paint) + (x : Float32) + (y : Float32)) + : Unit + (begin + (ssdSelfTestDrawRect + canvas x y (+ x (float32 30.0)) (+ y (float32 30.0)) fill) + (ssdSelfTestDrawRect + canvas x y (+ x (float32 30.0)) (+ y (float32 30.0)) border))) + (def (drawSelfTestOcrPage (bitmap : Bitmap)) + : Unit + (let ([canvas (ssdSelfTestCanvas bitmap)] + [fill (ssdSelfTestPaint (ssdSelfTestPaintAntiAliasFlag))] + [border (ssdSelfTestPaint (ssdSelfTestPaintAntiAliasFlag))] + [text (ssdSelfTestPaint (ssdSelfTestPaintAntiAliasFlag))]) + (begin + (ssdSelfTestPaintStyleSet fill (ssdSelfTestPaintFill)) + (ssdSelfTestPaintColorSet + fill + (ssdSelfTestColorRgb (int32 238) (int32 206) (int32 96))) + (ssdSelfTestPaintStyleSet border (ssdSelfTestPaintStroke)) + (ssdSelfTestPaintStrokeWidthSet border (float32 3.5)) + (ssdSelfTestPaintColorSet + border + (ssdSelfTestColorRgb (int32 20) (int32 20) (int32 20))) + (ssdSelfTestPaintColorSet text (ssdSelfTestColorBlack)) + (ssdSelfTestPaintTextSizeSet text (float32 52.0)) + (ssdSelfTestPaintTypefaceSet text (ssdSelfTestDefaultBold)) + (ssdSelfTestDrawText + canvas "LAB" (float32 235.0) (float32 220.0) text) + (ssdSelfTestDrawCell canvas fill border (float32 240.0) (float32 238.0)) + (ssdSelfTestDrawCell canvas fill border (float32 276.0) (float32 238.0)) + (ssdSelfTestDrawCell canvas fill border (float32 240.0) (float32 274.0)) + (ssdSelfTestDrawCell canvas fill border (float32 276.0) (float32 274.0)) + (ssdSelfTestDrawText + canvas "TRAN" (float32 545.0) (float32 410.0) text) + (ssdSelfTestDrawCell canvas fill border (float32 560.0) (float32 430.0)) + (ssdSelfTestDrawCell canvas fill border (float32 560.0) (float32 466.0)) + (ssdSelfTestDrawText + canvas "PH-1" (float32 250.0) (float32 700.0) text) + (ssdSelfTestDrawCell canvas fill border (float32 258.0) (float32 720.0)) + (ssdSelfTestDrawCell canvas fill border (float32 294.0) (float32 720.0))))) + (def (makeOcrSelfTestFixture) + : SsdSelfTestFixture + (let ([bitmap (ssdSelfTestBlankBitmap)]) + (begin + (drawSelfTestOcrPage bitmap) + (let ([session + (makeDetectionSession + "ssd-selftest-ocr-session" + (sourceKey + "ssdocrselftestfixture" + (int32 1) + SSD_SELF_TEST_DPI) + "SFB SSD OCR Self Test" + "selftest://ssd-review-ocr" + (int32 1) + (int32 1) + SSD_SELF_TEST_DPI + (int32 900) + (int32 1200))]) + (make-SsdSelfTestFixture + "ocr" + "SFB SSD OCR Self Test" + "ssdocrselftestfixture" + (int32 0) + (int32 1) + "selftest://ssd-review-ocr" + bitmap + session + (nullable-none String) + "SELFTEST_OCR_READY" + "ocr-loaded"))))) + (def (makeServerLabelsSelfTestFixture) + : SsdSelfTestFixture + (let ([bitmap (ssdSelfTestBlankBitmap)]) + (let ([session + (makeDetectionSession + "ssd-selftest-server-labels-session" + (sourceKey + "ssdserverlabelsfixture" + (int32 2) + SSD_SELF_TEST_DPI) + "omega-1-ssd-front.pdf" + "selftest://server-labels" + (int32 2) + (int32 2) + SSD_SELF_TEST_DPI + (int32 900) + (int32 1200))]) + (make-SsdSelfTestFixture + "server-labels" + "omega-1-ssd-front.pdf" + "ssdserverlabelsfixture" + (int32 1) + (int32 2) + "selftest://server-labels" + bitmap + session + (nullable-none String) + "SELFTEST_SERVER_LABELS_READY" + "server-labels-loaded")))) + (def (makeSelfTestFixture (mode : SsdSelfTestMode)) + : SsdSelfTestFixture + (if (SsdSelfTestMode-serverLabels mode) + (makeServerLabelsSelfTestFixture) + (if (SsdSelfTestMode-ocr mode) + (makeOcrSelfTestFixture) + (makeReviewSelfTestFixture)))) + (def (ssdSelfTestJsonCell + (id : String) + (x : Int32) + (y : Int32)) + : JSONObject + (let ([out (json-object-empty)]) + (begin + (json-object-put-string! out "id" id) + (json-object-put-int32! out "x" x) + (json-object-put-int32! out "y" y) + (json-object-put-int32! out "w" (int32 30)) + (json-object-put-int32! out "h" (int32 30)) + (json-object-put-string! out "detector" "self-test-proposal") + out))) + (def (ssdSelfTestStringArray4 + (a : String) + (b : String) + (c : String) + (d : String)) + : JSONArray + (let ([out (json-array-empty)]) + (begin + (json-array-put-string! out a) + (json-array-put-string! out b) + (json-array-put-string! out c) + (json-array-put-string! out d) + out))) + (def (ssdSelfTestIntArray4 + (a : Int32) + (b : Int32) + (c : Int32) + (d : Int32)) + : JSONArray + (let ([out (json-array-empty)]) + (begin + (json-array-put-int32! out a) + (json-array-put-int32! out b) + (json-array-put-int32! out c) + (json-array-put-int32! out d) + out))) + (def (ssdSelfTestProposalDetail + (label : String) + (boxTypeId : String) + (confidence : Float32) + (reason : String)) + : JSONObject + (let ([out (json-object-empty)]) + (begin + (json-object-put-string! out "label" label) + (json-object-put-string! out "box_type_id" boxTypeId) + (json-object-put-float32! out "confidence" confidence) + (json-object-put-string! out "reason" reason) + out))) + (def (selfTestProposalJson (session : SsdSession)) + : JSONObject + (let ([cells (json-array-empty)] + [groups (json-array-empty)] + [group (json-object-empty)] + [vision (ssdSelfTestProposalDetail + "lab" + "" + (float32 0.99) + "self-test accepted visual proposal")] + [noise (json-object-empty)] + [source (json-object-empty)] + [image (json-object-empty)] + [proposal (json-object-empty)]) + (begin + (json-array-put-json-object! + cells (ssdSelfTestJsonCell "pc0001" (int32 240) (int32 238))) + (json-array-put-json-object! + cells (ssdSelfTestJsonCell "pc0002" (int32 276) (int32 238))) + (json-array-put-json-object! + cells (ssdSelfTestJsonCell "pc0003" (int32 240) (int32 274))) + (json-array-put-json-object! + cells (ssdSelfTestJsonCell "pc0004" (int32 276) (int32 274))) + (json-object-put-string! group "id" "vg0001") + (json-object-put-string! group "label" "lab?") + (json-object-put-string! group "box_type_id" "") + (json-object-put-string! group "status" "candidate") + (json-object-put-int32! group "count" (int32 4)) + (json-object-put-json-array! + group "bbox" + (ssdSelfTestIntArray4 + (int32 240) (int32 238) (int32 306) (int32 304))) + (json-object-put-json-array! + group "cell_ids" + (ssdSelfTestStringArray4 "pc0001" "pc0002" "pc0003" "pc0004")) + (json-object-put-json-object! + group + "proposal" + (ssdSelfTestProposalDetail + "lab" + "" + (float32 0.98) + "self-test bundled proposal")) + (json-object-put-bool! vision "accepted" #t) + (json-object-put-json-object! group "vision_review" vision) + (json-object-put-string! noise "id" "rawbad0001") + (json-object-put-string! noise "label" "sensor?") + (json-object-put-string! noise "box_type_id" "22") + (json-object-put-string! noise "status" "candidate") + (json-object-put-int32! noise "count" (int32 1)) + (json-object-put-json-array! + noise "bbox" + (ssdSelfTestIntArray4 + (int32 390) (int32 238) (int32 430) (int32 304))) + (json-object-put-json-array! noise "cell_ids" (json-array-empty)) + (json-object-put-json-object! + noise + "proposal" + (ssdSelfTestProposalDetail + "sensor" + "22" + (float32 0.99) + "self-test unreviewed raw proposal must be hidden")) + (json-array-put-json-object! groups group) + (json-array-put-json-object! groups noise) + (json-object-put-string! source "kind" "pdf") + (json-object-put-string! source "path" (SsdSession-sourceUri session)) + (json-object-put-string! source "name" (SsdSession-sourceName session)) + (json-object-put-int32! source "page" (SsdSession-page session)) + (json-object-put-int32! + source "page_count" (SsdSession-pageCount session)) + (json-object-put-int32! source "dpi" (SsdSession-dpi session)) + (json-object-put-int32! + image "width" (SsdSession-imageWidth session)) + (json-object-put-int32! + image "height" (SsdSession-imageHeight session)) + (json-object-put-int32! proposal "schema_version" (int32 1)) + (json-object-put-string! + proposal "proposal_schema" "ssd-proposal-v1") + (json-object-put-string! + proposal "source_key" (SsdSession-sourceKey session)) + (json-object-put-json-object! proposal "source" source) + (json-object-put-json-object! proposal "image" image) + (json-object-put-json-array! proposal "cells" cells) + (json-object-put-json-array! proposal "groups" groups) + proposal))))))) new file mode 100644 --- /dev/null +++ b/templates/ssd-review-parts/SsdSelfTestMode.ss @@ -0,0 +1,46 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/sfb/ssdreview/SsdSelfTestMode.kt" + (kotlin-imports (android content Intent)) + (typed-library (com sfb ssdreview) + (export EXTRA_SELF_TEST EXTRA_SELF_TEST_OCR + EXTRA_SELF_TEST_SERVER_LABELS SELF_TEST_SOURCE_KEY + make-SsdSelfTestMode SsdSelfTestMode? + SsdSelfTestMode-enabled SsdSelfTestMode-ocr + SsdSelfTestMode-serverLabels ssdSelfTestModeFromIntent + ssdSelfTestFixtureKind) + (type Intent) + (val EXTRA_SELF_TEST : String "sfb.ssdreview.selftest" + (modifiers internal const)) + (val EXTRA_SELF_TEST_OCR : String "sfb.ssdreview.selftest.ocr" + (modifiers internal const)) + (val EXTRA_SELF_TEST_SERVER_LABELS : String + "sfb.ssdreview.selftest.server_labels" + (modifiers internal const)) + (val SELF_TEST_SOURCE_KEY : String "ssd-selftest-p0001-d144" + (modifiers internal const)) + (record SsdSelfTestMode + ((enabled : Bool) (ocr : Bool) (serverLabels : Bool))) + (extern + (ssdSelfTestIntentBoolean + (intent : Intent) + (name : String) + (fallback : Bool)) + : Bool + (kotlin-member-call getBooleanExtra)) + (def (ssdSelfTestModeFromIntent (intent : Intent)) + : SsdSelfTestMode + (make-SsdSelfTestMode + (ssdSelfTestIntentBoolean intent EXTRA_SELF_TEST #f) + (ssdSelfTestIntentBoolean intent EXTRA_SELF_TEST_OCR #f) + (ssdSelfTestIntentBoolean + intent + EXTRA_SELF_TEST_SERVER_LABELS + #f))) + (def (ssdSelfTestFixtureKind (mode : SsdSelfTestMode)) + : String + (if (SsdSelfTestMode-serverLabels mode) + "server-labels" + (if (SsdSelfTestMode-ocr mode) "ocr" "review"))))))) new file mode 100644 --- /dev/null +++ b/templates/ssd-review-parts/SsdSelfTestTelemetry.ss @@ -0,0 +1,353 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/sfb/ssdreview/SsdSelfTestTelemetry.kt" + (kotlin-imports (android graphics Bitmap) (android graphics Color) + (org json JSONArray) (org json JSONObject)) + (typed-library (com sfb ssdreview) + (export selfTestLabelCount truthRawGroupCount + truthSuppressedGroupCount truthUsefulGroupCount + selfTestBitmapNonwhiteSamples ssdSelfTestStatePayload + logSelfTestState) + (type Bitmap) (type JSONArray) (type JSONObject) + (type Int32) (type Float32) (type FloatArray) + (extern + (ssdSelfTestBitmapWidth (bitmap : Bitmap)) + : Int32 + (kotlin-member-get width)) + (extern + (ssdSelfTestBitmapHeight (bitmap : Bitmap)) + : Int32 + (kotlin-member-get height)) + (extern + (ssdSelfTestBitmapPixel + (bitmap : Bitmap) + (x : Int32) + (y : Int32)) + : Int32 + (kotlin-member-call getPixel)) + (extern + (ssdSelfTestColorRed (color : Int32)) + : Int32 + (kotlin-call Color red)) + (extern + (ssdSelfTestColorGreen (color : Int32)) + : Int32 + (kotlin-call Color green)) + (extern + (ssdSelfTestColorBlue (color : Int32)) + : Int32 + (kotlin-call Color blue)) + (def (ssdSelfTestReviewedStatus (status : String)) + : Bool + (or (equal? status "reviewed") (equal? status "approved"))) + (def (selfTestLabelCount (session : SsdSession)) + : Int32 + (for/fold + ((count (int32 0))) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (if (string-blank? + (SsdGroup-label (list-ref (SsdSession-groups session) i))) + count + (+ count (int32 1))))) + (def (ssdSelfTestQuestionLabelCount (session : SsdSession)) + : Int32 + (for/fold + ((count (int32 0))) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (if (string-ends-with? + (string-trim + (SsdGroup-label (list-ref (SsdSession-groups session) i))) + "?") + (+ count (int32 1)) + count))) + (def (ssdSelfTestReviewedCount (session : SsdSession)) + : Int32 + (for/fold + ((count (int32 0))) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (if (ssdSelfTestReviewedStatus + (SsdGroup-status (list-ref (SsdSession-groups session) i))) + (+ count (int32 1)) + count))) + (def (ssdSelfTestOcrGroupCount (session : SsdSession)) + : Int32 + (for/fold + ((count (int32 0))) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (if (string-contains? + (SsdGroup-notes (list-ref (SsdSession-groups session) i)) + "OCR:") + (+ count (int32 1)) + count))) + (def (ssdSelfTestProposalGroupCount (session : SsdSession)) + : Int32 + (for/fold + ((count (int32 0))) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (let ([notes + (SsdGroup-notes + (list-ref (SsdSession-groups session) i))]) + (if (or (string-starts-with? notes "Proposal") + (string-starts-with? notes "AI proposal")) + (+ count (int32 1)) + count)))) + (def (ssdSelfTestLabels (session : SsdSession)) + : String + (for/fold + ((out "")) + ((i (in-range (int32 0) (list-size (SsdSession-groups session))))) + (let ([group (list-ref (SsdSession-groups session) i)]) + (let ([entry + (string-append + (SsdGroup-id group) + (string-append + ":" + (string-append + (SsdGroup-label group) + (string-append + ":" + (string-append + (SsdGroup-status group) + (string-append ":" (SsdGroup-boxTypeId group)))))))]) + (if (string-blank? out) + entry + (string-append out (string-append "|" entry))))))) + (def (ssdSelfTestOcrText (session : SsdSession)) + : String + (let ([joined + (for/fold + ((out "")) + ((i (in-range + (int32 0) + (list-size (SsdSession-ocrWords session))))) + (let ([word + (OcrWord-text + (list-ref (SsdSession-ocrWords session) i))]) + (if (string-blank? out) + word + (string-append out (string-append " " word)))))]) + (string-take joined (int32 300)))) + (def (truthRawGroupCount (truth : (Nullable JSONObject))) + : Int32 + (if (nullable-null? truth) + (int32 0) + (let ([groups + (json-object-opt-json-array + (nullable-get truth) + "groups")]) + (if (nullable-null? groups) + (int32 0) + (json-array-length (nullable-get groups)))))) + (def (truthSuppressedGroupCount (truth : (Nullable JSONObject))) + : Int32 + (if (nullable-null? truth) + (int32 0) + (let ([groups + (json-object-opt-json-array + (nullable-get truth) + "suppressed_groups")]) + (if (nullable-null? groups) + (int32 0) + (json-array-length (nullable-get groups)))))) + (def (truthUsefulGroupCount (truth : (Nullable JSONObject))) + : Int32 + (if (nullable-null? truth) + (int32 0) + (let ([groups + (json-object-opt-json-array + (nullable-get truth) + "groups")]) + (if (nullable-null? groups) + (int32 0) + (for/fold + ((count (int32 0))) + ((i (in-range + (int32 0) + (json-array-length (nullable-get groups))))) + (let ([group + (json-array-opt-json-object + (nullable-get groups) + i)]) + (if (nullable-null? group) + count + (let ([label + (string-trim + (json-object-opt-string + (nullable-get group) + "label"))] + [status + (string-lowercase + (string-trim + (json-object-opt-string + (nullable-get group) + "status")))]) + (if (and (not (string-blank? label)) + (not (string-ends-with? label "?")) + (ssdSelfTestReviewedStatus status)) + (+ count (int32 1)) + count))))))))) + (def (ssdSelfTestPositiveStep (dimension : Int32)) + : Int32 + (let ([candidate (/ dimension (int32 40))]) + (if (< candidate (int32 1)) (int32 1) candidate))) + (def (selfTestBitmapNonwhiteSamples + (bitmap : (Nullable Bitmap))) + : Int32 + (if (nullable-null? bitmap) + (int32 0) + (let ([image (nullable-get bitmap)]) + (let ([width (ssdSelfTestBitmapWidth image)] + [height (ssdSelfTestBitmapHeight image)]) + (let ([stepX (ssdSelfTestPositiveStep width)] + [stepY (ssdSelfTestPositiveStep height)]) + (var ((count (int32 0)) (y (int32 0))) + (begin + (while + (< y height) + (begin + (var ((x (int32 0))) + (while + (< x width) + (let ([pixel + (ssdSelfTestBitmapPixel image x y)]) + (begin + (if (or + (< (ssdSelfTestColorRed pixel) + (int32 245)) + (< (ssdSelfTestColorGreen pixel) + (int32 245)) + (< (ssdSelfTestColorBlue pixel) + (int32 245))) + (set! count (+ count (int32 1))) + (begin)) + (set! x (+ x stepX)))))) + (set! y (+ y stepY)))) + count))))))) + (def (ssdSelfTestGridText (rect : FloatArray)) + : String + (let ([grid (manualCellGridDimensions rect (int32 4))]) + (string-append + (int32->string (pair-first grid)) + (string-append "x" (int32->string (pair-second grid)))))) + (def (ssdSelfTestViewportScale + (viewport : (Nullable ViewportState))) + : Float32 + (if (nullable-null? viewport) + (float32 0.0) + (ViewportState-scale (nullable-get viewport)))) + (def (ssdSelfTestViewportOffsetX + (viewport : (Nullable ViewportState))) + : Float32 + (if (nullable-null? viewport) + (float32 0.0) + (ViewportState-offsetX (nullable-get viewport)))) + (def (ssdSelfTestViewportOffsetY + (viewport : (Nullable ViewportState))) + : Float32 + (if (nullable-null? viewport) + (float32 0.0) + (ViewportState-offsetY (nullable-get viewport)))) + (def (ssdSelfTestViewportRotation + (viewport : (Nullable ViewportState))) + : Int32 + (if (nullable-null? viewport) + (int32 0) + (ViewportState-rotationDegrees (nullable-get viewport)))) + (def (ssdSelfTestSelectedText + (selected : (Nullable String))) + : String + (if (nullable-null? selected) "" (nullable-get selected))) + (def (ssdSelfTestStatePayload + (stage : String) + (session : SsdSession) + (selected : (Nullable String)) + (selectMode : Bool) + (appendMode : Bool) + (ssdAreaMode : Bool) + (viewport : (Nullable ViewportState)) + (bitmap : (Nullable Bitmap))) + : JSONObject + (let ([out (json-object-empty)]) + (begin + (json-object-put-string! out "stage" stage) + (json-object-put-int32! + out "groups" (list-size (SsdSession-groups session))) + (json-object-put-int32! + out "label_count" (selfTestLabelCount session)) + (json-object-put-int32! + out "question_label_count" + (ssdSelfTestQuestionLabelCount session)) + (json-object-put-int32! + out "reviewed_count" (ssdSelfTestReviewedCount session)) + (json-object-put-int32! + out "ocr_word_count" (list-size (SsdSession-ocrWords session))) + (json-object-put-int32! + out "ocr_group_count" (ssdSelfTestOcrGroupCount session)) + (json-object-put-int32! + out "proposal_group_count" + (ssdSelfTestProposalGroupCount session)) + (json-object-put-string! out "ocr_text" (ssdSelfTestOcrText session)) + (json-object-put-string! + out "selected" (ssdSelfTestSelectedText selected)) + (json-object-put-bool! out "select_mode" selectMode) + (json-object-put-bool! out "append_mode" appendMode) + (json-object-put-bool! out "ssd_area_mode" ssdAreaMode) + (json-object-put-float32! + out "viewport_scale" (ssdSelfTestViewportScale viewport)) + (json-object-put-float32! + out "viewport_offset_x" (ssdSelfTestViewportOffsetX viewport)) + (json-object-put-float32! + out "viewport_offset_y" (ssdSelfTestViewportOffsetY viewport)) + (json-object-put-int32! + out "viewport_rotation" (ssdSelfTestViewportRotation viewport)) + (json-object-put-string! + out "manual_grid_horizontal" + (ssdSelfTestGridText + (float-array + (float32 0.0) (float32 0.0) + (float32 160.0) (float32 40.0)))) + (json-object-put-string! + out "manual_grid_vertical" + (ssdSelfTestGridText + (float-array + (float32 0.0) (float32 0.0) + (float32 40.0) (float32 160.0)))) + (json-object-put-string! + out "manual_grid_square" + (ssdSelfTestGridText + (float-array + (float32 0.0) (float32 0.0) + (float32 80.0) (float32 80.0)))) + (json-object-put-int32! + out "bitmap_nonwhite_samples" + (selfTestBitmapNonwhiteSamples bitmap)) + (json-object-put-string! out "labels" (ssdSelfTestLabels session)) + out))) + (def (logSelfTestState + (enabled : Bool) + (stage : String) + (session : (Nullable SsdSession)) + (selected : (Nullable String)) + (selectMode : Bool) + (appendMode : Bool) + (ssdAreaMode : Bool) + (viewport : (Nullable ViewportState)) + (bitmap : (Nullable Bitmap)) + (logger : (-> String JSONObject Unit))) + : Unit + (if (or (not enabled) (nullable-null? session)) + (begin) + (invoke + logger + "ssd-selftest-state" + (ssdSelfTestStatePayload + stage + (nullable-get session) + selected + selectMode + appendMode + ssdAreaMode + viewport + bitmap)))))))) new file mode 100644 --- /dev/null +++ b/templates/ssd-review-parts/TruthStoreSelfTest.ss @@ -0,0 +1,71 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/sfb/ssdreview/TruthStoreSelfTest.kt" + (kotlin-imports (java io File) (java lang IllegalArgumentException) + (org json JSONObject)) + (typed-library (com sfb ssdreview) + (export truthStoreSaveProposalSnapshotForSelfTest) + (type File) (type IllegalArgumentException) (type Int32) + (type JSONObject) + (type TruthStore) + (extern + (truthStoreSelfTestInvalidSourceKey (message : String)) + : IllegalArgumentException + (kotlin-call IllegalArgumentException)) + (extern + (truthStoreSelfTestRoot (store : TruthStore)) + : File + (kotlin-member-get root)) + (extern + (truthStoreSelfTestAtomicWriteText + (store : TruthStore) + (destination : File) + (text : String)) + : Unit + (kotlin-member-call atomicWriteText)) + (extern + (truthStoreSelfTestPrettyJson + (json : JSONObject) + (indent : Int32)) + : String + (kotlin-member-call toString)) + (extern + (truthStoreSelfTestFile + (directory : File) + (name : String)) + : File + (kotlin-call File)) + (extern + (truthStoreSelfTestMkdirs (directory : File)) + : Bool + (kotlin-member-call mkdirs)) + (def (truthStoreSaveProposalSnapshotForSelfTest + (store : TruthStore) + (proposal : JSONObject)) + : File + (let ([validated + (validatedSourceKey + (json-object-opt-string proposal "source_key"))]) + (if (nullable-null? validated) + (throw + (truthStoreSelfTestInvalidSourceKey "Invalid source key") + File) + (let ([proposalDir + (truthStoreSelfTestFile + (truthStoreSelfTestRoot store) + "proposals")]) + (let ([file + (truthStoreSelfTestFile + proposalDir + (string-append + (nullable-get validated) + ".proposed.json"))]) + (begin + (truthStoreSelfTestMkdirs proposalDir) + (truthStoreSelfTestAtomicWriteText + store + file + (truthStoreSelfTestPrettyJson proposal (int32 2))) + file)))))))))) new file mode 100644 --- /dev/null +++ b/templates/ssd-review-selftest-test.ss @@ -0,0 +1,8 @@ +(import (jerboa prelude)) + +(def fragment + '((include-fragment "ssd-review.ss") + (include-fragment "ssd-review-parts/SsdSelfTestMode.ss") + (include-fragment "ssd-review-parts/SsdSelfTestFixture.ss") + (include-fragment "ssd-review-parts/SsdSelfTestTelemetry.ss") + (include-fragment "ssd-review-parts/TruthStoreSelfTest.ss"))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/ssd-selftest-app.ss @@ -0,0 +1,14 @@ +(import (jerboa prelude))