Assemble Original Tactics from typed Jerboa modules
ober
052a3141cd11859e81a1527f972a1495fe87a176
new file mode 100644 --- /dev/null +++ b/templates/original-tactics-parts/HexMath.ss @@ -0,0 +1,768 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/jerboa/originaltactics/HexMath.kt" + (kotlin-imports (org json JSONArray) (org json JSONObject)) + (typed-library (com jerboa originaltactics) + (export make-ProjectedHelmPose ProjectedHelmPose? + make-ProjectedHelmMove ProjectedHelmMove? + make-ProjectedRangePoint ProjectedRangePoint? + hexRangeFromPositions hexRange currentBattleRange + movementImpulsesForSpeed nextMoveImpulse maneuverMapFromJson + projectedHelmMoves projectedHelmPoseAt + projectedRangeForecast maneuverAbbreviation) + (type Any) (type Int32) (type JSONArray) (type JSONObject) + (record + ProjectedHelmPose + ((q : Int32) (r : Int32) (facing : Int32) (speed : Int32) + (turnMode : String) (distanceSinceTurn : Int32))) + (record + ProjectedHelmMove + ((impulse : Int32) + (maneuver : (Nullable String)) + (pose : ProjectedHelmPose))) + (record + ProjectedRangePoint + ((impulse : Int32) (range : Int32))) + (extern + (asJsonArray (value : Any)) + : + (Nullable JSONArray) + (kotlin-safe-cast JSONArray)) + (extern + (asJsonObject (value : Any)) + : + (Nullable JSONObject) + (kotlin-safe-cast JSONObject)) + (extern + (anyToString (value : Any)) + : + String + (kotlin-member-call toString)) + (extern + (jsonObjectKeys (json : JSONObject)) + : + (Iterator String) + (kotlin-member-call keys)) + (extern + (iteratorHasNext (items : (Iterator String))) + : + Bool + (kotlin-member-call hasNext)) + (extern + (iteratorNext (items : (Iterator String))) + : + String + (kotlin-member-call next)) + (def (int32Abs (value : Int32)) + : + Int32 + (if (< value (int32 0)) (- (int32 0) value) value)) + (def (clampImpulse (value : Int32)) + : + Int32 + (if (< value (int32 0)) + (int32 0) + (if (> value (int32 32)) (int32 32) value))) + (def (atLeastOne (value : Int32)) + : + Int32 + (if (< value (int32 1)) (int32 1) value)) + (def (betweenInt32? + (value : Int32) + (low : Int32) + (high : Int32)) + : + Bool + (and (>= value low) (<= value high))) + (def (hexRangeFromPositions + (alpha : (Nullable JSONObject)) + (beta : (Nullable JSONObject))) + : + (Nullable Int32) + (if (or (nullable-null? alpha) (nullable-null? beta)) + (nullable-none Int32) + (nullable-some + (hexRange + (json-object-opt-int32-default + (nullable-get alpha) + "q" + (int32 0)) + (json-object-opt-int32-default + (nullable-get alpha) + "r" + (int32 0)) + (json-object-opt-int32-default + (nullable-get beta) + "q" + (int32 0)) + (json-object-opt-int32-default + (nullable-get beta) + "r" + (int32 0)))))) + (def (hexRange + (q1 : Int32) + (r1 : Int32) + (q2 : Int32) + (r2 : Int32)) + : + Int32 + (let ([dq (- q2 q1)] [dr (- r2 r1)]) + (let ([ds (- (int32 0) (+ dq dr))]) + (/ (+ (+ (int32Abs dq) (int32Abs dr)) (int32Abs ds)) + (int32 2))))) + (def (nullableAnyToString + (value : (Nullable Any)) + (fallback : String)) + : + String + (if (nullable-null? value) + fallback + (anyToString (nullable-get value)))) + (def (currentBattleRange (battle : (Nullable JSONObject))) + : + String + (if (nullable-null? battle) + "-" + (let ([computed (hexRangeFromPositions + (json-object-opt-json-object + (nullable-get battle) + "alpha-position") + (json-object-opt-json-object + (nullable-get battle) + "beta-position"))]) + (if (nullable-null? computed) + (nullableAnyToString + (json-object-opt-any + (nullable-get battle) + "range") + "-") + (int32->string (nullable-get computed)))))) + (def (movementImpulsesForSpeed (speed : Int32)) + : + (MutableList Int32) + (let ([moves (clampImpulse speed)] + [out (mutable-list-empty Int32)]) + (begin + (for/fold + ((ignored (int32 0))) + ((step (in-range (int32 1) (+ moves (int32 1))))) + (begin + (mutable-list-add! + out + (/ (+ (- (* step (int32 32)) (int32 1)) moves) + moves)) + ignored)) + out))) + (def (nextMoveImpulse + (position : (Nullable JSONObject)) + (currentImpulse : Int32)) + : + (Nullable Int32) + (if (nullable-null? position) + (nullable-none Int32) + (let ([moves (movementImpulsesForSpeed + (json-object-opt-int32-default + (nullable-get position) + "speed" + (int32 0)))]) + (for/fold + ((found (nullable-none Int32))) + ((index (in-range (int32 0) (list-size moves)))) + (if (nullable-null? found) + (let ([candidate (list-ref moves index)]) + (if (> candidate currentImpulse) + (nullable-some candidate) + found)) + found))))) + (def (validManeuverPair? + (impulse : Int32) + (maneuver : String)) + : + Bool + (and (betweenInt32? impulse (int32 1) (int32 32)) + (not (string-blank? maneuver)))) + (def (addManeuverPair! + (out : (MutableMap Int32 String)) + (impulse : Int32) + (maneuver : String)) + : + Unit + (if (validManeuverPair? impulse maneuver) + (mutable-map-put! out impulse maneuver) + (begin))) + (def (addManeuverArray! + (out : (MutableMap Int32 String)) + (pair : JSONArray)) + : + Unit + (addManeuverPair! + out + (json-array-opt-int32 pair (int32 0) (int32 -1)) + (json-array-opt-string pair (int32 1)))) + (def (addManeuverObjectPair! + (out : (MutableMap Int32 String)) + (item : JSONObject)) + : + Unit + (let ([pair (json-object-opt-json-array item "$pair")]) + (if (nullable-null? pair) + (begin) + (addManeuverArray! out (nullable-get pair))))) + (def (addManeuverRawItem! + (out : (MutableMap Int32 String)) + (item : (Nullable Any))) + : + Unit + (if (nullable-null? item) + (begin) + (let ([asArray (asJsonArray (nullable-get item))] + [asObject (asJsonObject (nullable-get item))]) + (if (nullable-null? asArray) + (if (nullable-null? asObject) + (begin) + (addManeuverObjectPair! + out + (nullable-get asObject))) + (addManeuverArray! + out + (nullable-get asArray)))))) + (def (addManeuverArrayItems! + (out : (MutableMap Int32 String)) + (raw : JSONArray)) + : + Unit + (begin + (for/fold + ((ignored (int32 0))) + ((index (in-range (int32 0) (json-array-length raw)))) + (begin + (addManeuverRawItem! + out + (json-array-opt-any raw index)) + ignored)) + (begin))) + (def (addManeuverObjectItems! + (out : (MutableMap Int32 String)) + (raw : JSONObject)) + : + Unit + (let ([keys (jsonObjectKeys raw)]) + (while + (iteratorHasNext keys) + (let ([key (iteratorNext keys)]) + (let ([impulse (string->int32-or-null key)]) + (if (nullable-null? impulse) + (begin) + (addManeuverPair! + out + (nullable-get impulse) + (json-object-opt-string-default + raw + key + "")))))))) + (def (maneuverMapFromJson (raw : (Nullable Any))) + : + (MutableMap Int32 String) + (let ([out (mutable-map-empty Int32 String)]) + (begin + (if (nullable-null? raw) + (begin) + (let ([asArray (asJsonArray (nullable-get raw))] + [asObject (asJsonObject (nullable-get raw))]) + (if (nullable-null? asArray) + (if (nullable-null? asObject) + (begin) + (addManeuverObjectItems! + out + (nullable-get asObject))) + (addManeuverArrayItems! + out + (nullable-get asArray))))) + out))) + (def (startingProjectedHelmPose (position : JSONObject)) + : + ProjectedHelmPose + (make-ProjectedHelmPose (json-object-opt-int32-default position "q" (int32 0)) + (json-object-opt-int32-default position "r" (int32 0)) + (normalizedHelmFacing + (json-object-opt-int32-default + position + "facing" + (int32 0))) + (clampImpulse + (json-object-opt-int32-default + position + "speed" + (int32 0))) + (json-object-opt-string-default position "turn-mode" "c") + (json-object-opt-int32-default + position + "distance-since-turn" + (int32 0)))) + (def (projectedHelmMoves + (position : (Nullable JSONObject)) + (maneuvers : (Map Int32 String)) + (currentImpulse : Int32) + (maxMoves : Int32)) + : + (MutableList ProjectedHelmMove) + (let ([out (mutable-list-empty ProjectedHelmMove)]) + (if (nullable-null? position) + out + (let ([movementImpulses (movementImpulsesForSpeed + (json-object-opt-int32-default + (nullable-get position) + "speed" + (int32 0)))]) + (var ((pose + (startingProjectedHelmPose + (nullable-get position)))) + (begin + (for/fold + ((ignored (int32 0))) + ((index + (in-range + (int32 0) + (list-size movementImpulses)))) + (let ([impulse (list-ref + movementImpulses + index)]) + (if (and (> impulse currentImpulse) + (< (list-size out) + (atLeastOne maxMoves))) + (let ([maneuver (map-ref-or-null + maneuvers + impulse)]) + (begin + (set! pose + (applyProjectedHelmMove + pose + maneuver)) + (mutable-list-add! + out + (make-ProjectedHelmMove + impulse + maneuver + pose)) + ignored)) + ignored))) + out)))))) + (def (projectedHelmPoseAt + (position : (Nullable JSONObject)) + (projected : (List ProjectedHelmMove)) + (impulse : Int32)) + : + (Nullable ProjectedHelmPose) + (let ([found (for/fold + ((candidate + (nullable-none ProjectedHelmPose))) + ((index + (in-range + (int32 0) + (list-size projected)))) + (let ([move (list-ref projected index)]) + (if (<= (ProjectedHelmMove-impulse move) + impulse) + (nullable-some + (ProjectedHelmMove-pose move)) + candidate)))]) + (if (nullable-null? found) + (if (nullable-null? position) + (nullable-none ProjectedHelmPose) + (nullable-some + (startingProjectedHelmPose + (nullable-get position)))) + found))) + (def (hasProjectedImpulse? + (projected : (List ProjectedHelmMove)) + (impulse : Int32)) + : + Bool + (for/fold + ((found #f)) + ((index (in-range (int32 0) (list-size projected)))) + (or found + (= (ProjectedHelmMove-impulse + (list-ref projected index)) + impulse)))) + (def (projectedRangeForecast (alphaPosition : (Nullable JSONObject)) + (betaPosition : (Nullable JSONObject)) + (alphaManeuversRaw : (Nullable Any)) + (betaManeuversRaw : (Nullable Any)) + (currentImpulse : Int32) + (maxMoves : Int32 (default (int32 8))) + (labelLimit : Int32 (default (int32 5)))) + : + (MutableList ProjectedRangePoint) + (let ([out (mutable-list-empty ProjectedRangePoint)]) + (if (or (nullable-null? alphaPosition) + (nullable-null? betaPosition)) + out + (let ([alphaProjected (projectedHelmMoves + alphaPosition + (maneuverMapFromJson + alphaManeuversRaw) + currentImpulse + maxMoves)] + [betaProjected (projectedHelmMoves + betaPosition + (maneuverMapFromJson + betaManeuversRaw) + currentImpulse + maxMoves)]) + (var ((previousRange (nullable-none Int32))) + (begin + (for/fold + ((ignored (int32 0))) + ((impulse + (in-range (int32 1) (int32 33)))) + (if (and (< (list-size out) + (atLeastOne labelLimit)) + (or (hasProjectedImpulse? + alphaProjected + impulse) + (hasProjectedImpulse? + betaProjected + impulse))) + (let ([alphaPose (projectedHelmPoseAt + alphaPosition + alphaProjected + impulse)] + [betaPose (projectedHelmPoseAt + betaPosition + betaProjected + impulse)]) + (if (or (nullable-null? alphaPose) + (nullable-null? betaPose)) + ignored + (let ([range (hexRange + (ProjectedHelmPose-q + (nullable-get + alphaPose)) + (ProjectedHelmPose-r + (nullable-get + alphaPose)) + (ProjectedHelmPose-q + (nullable-get + betaPose)) + (ProjectedHelmPose-r + (nullable-get + betaPose)))]) + (let ([important (or (<= range + (int32 + 2)) + (or (nullable-null? + previousRange) + (not (= range + (nullable-get + previousRange)))))]) + (begin + (set! previousRange + (nullable-some range)) + (if important + (mutable-list-add! + out + (make-ProjectedRangePoint + impulse + range)) + (begin)) + ignored))))) + ignored)) + out)))))) + (def (maneuverAbbreviation (maneuver : String)) + : + String + (if (equal? maneuver "left") + "L" + (if (equal? maneuver "right") + "R" + (if (equal? maneuver "sideslip-left") + "SL" + (if (equal? maneuver "sideslip-right") + "SR" + (if (equal? maneuver "het") + "HET" + (string-uppercase + (string-take + maneuver + (int32 3))))))))) + (def (applyProjectedHelmMove + (pose : ProjectedHelmPose) + (maneuver : (Nullable String))) + : + ProjectedHelmPose + (if (nullable-null? maneuver) + (moveForward pose) + (let ([name (nullable-get maneuver)]) + (if (equal? name "left") + (if (canProjectedTurn? pose) + (moveForward + (make-ProjectedHelmPose (ProjectedHelmPose-q pose) + (ProjectedHelmPose-r pose) + (normalizedHelmFacing + (- (ProjectedHelmPose-facing pose) + (int32 1))) + (ProjectedHelmPose-speed pose) + (ProjectedHelmPose-turnMode pose) + (int32 0))) + pose) + (if (equal? name "right") + (if (canProjectedTurn? pose) + (moveForward + (make-ProjectedHelmPose (ProjectedHelmPose-q pose) + (ProjectedHelmPose-r pose) + (normalizedHelmFacing + (+ (ProjectedHelmPose-facing pose) + (int32 1))) + (ProjectedHelmPose-speed pose) + (ProjectedHelmPose-turnMode pose) + (int32 0))) + pose) + (if (equal? name "sideslip-left") + (moveInDirection + pose + (normalizedHelmFacing + (- (ProjectedHelmPose-facing pose) + (int32 1)))) + (if (equal? name "sideslip-right") + (moveInDirection + pose + (normalizedHelmFacing + (+ (ProjectedHelmPose-facing + pose) + (int32 1)))) + (if (equal? name "het") + (moveForward + (make-ProjectedHelmPose (ProjectedHelmPose-q pose) + (ProjectedHelmPose-r pose) + (normalizedHelmFacing + (+ (ProjectedHelmPose-facing + pose) + (int32 3))) + (ProjectedHelmPose-speed + pose) + (ProjectedHelmPose-turnMode + pose) + (int32 0))) + (moveForward pose))))))))) + (def (moveForward (pose : ProjectedHelmPose)) + : + ProjectedHelmPose + (moveInDirection pose (ProjectedHelmPose-facing pose))) + (def (directionDeltaQ (direction : Int32)) + : + Int32 + (let ([facing (normalizedHelmFacing direction)]) + (if (or (= facing (int32 0)) (= facing (int32 1))) + (int32 1) + (if (or (= facing (int32 3)) (= facing (int32 4))) + (int32 -1) + (int32 0))))) + (def (directionDeltaR (direction : Int32)) + : + Int32 + (let ([facing (normalizedHelmFacing direction)]) + (if (or (= facing (int32 1)) (= facing (int32 2))) + (int32 -1) + (if (or (= facing (int32 4)) (= facing (int32 5))) + (int32 1) + (int32 0))))) + (def (moveInDirection + (pose : ProjectedHelmPose) + (direction : Int32)) + : + ProjectedHelmPose + (make-ProjectedHelmPose + (+ (ProjectedHelmPose-q pose) + (directionDeltaQ direction)) + (+ (ProjectedHelmPose-r pose) + (directionDeltaR direction)) + (ProjectedHelmPose-facing pose) + (ProjectedHelmPose-speed pose) + (ProjectedHelmPose-turnMode pose) + (+ (ProjectedHelmPose-distanceSinceTurn pose) + (int32 1)))) + (def (canProjectedTurn? (pose : ProjectedHelmPose)) + : + Bool + (>= (ProjectedHelmPose-distanceSinceTurn pose) + (turnModeRequiredDistance + (ProjectedHelmPose-turnMode pose) + (ProjectedHelmPose-speed pose)))) + (def (turnModeRequiredDistance + (turnMode : String) + (speed : Int32)) + : + Int32 + (let ([mode (string-lowercase turnMode)]) + (if (equal? mode "seeking-weapon") + (if (betweenInt32? speed (int32 1) (int32 32)) + (int32 1) + (int32 0)) + (if (equal? mode "shuttle") + (turnModeShuttleDistance speed) + (if (equal? mode "aa") + (turnModeAaDistance speed) + (if (equal? mode "a") + (turnModeADistance speed) + (if (equal? mode "b") + (turnModeBDistance speed) + (if (equal? mode "d") + (turnModeDDistance speed) + (if (equal? mode "e") + (turnModeEDistance speed) + (if (equal? mode "f") + (turnModeFDistance speed) + (turnModeCDistance + speed))))))))))) + (def (turnModeShuttleDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 1) (int32 11)) + (int32 1) + (if (betweenInt32? speed (int32 12) (int32 23)) + (int32 2) + (if (>= speed (int32 24)) (int32 3) (int32 0))))) + (def (turnModeAaDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 8)) + (int32 1) + (if (betweenInt32? speed (int32 9) (int32 16)) + (int32 2) + (if (betweenInt32? speed (int32 17) (int32 24)) + (int32 3) + (if (>= speed (int32 25)) + (int32 4) + (int32 0)))))) + (def (turnModeADistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 6)) + (int32 1) + (if (betweenInt32? speed (int32 7) (int32 12)) + (int32 2) + (if (betweenInt32? speed (int32 13) (int32 19)) + (int32 3) + (if (betweenInt32? speed (int32 20) (int32 26)) + (int32 4) + (if (>= speed (int32 27)) + (int32 5) + (int32 0))))))) + (def (turnModeBDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 5)) + (int32 1) + (if (betweenInt32? speed (int32 6) (int32 10)) + (int32 2) + (if (betweenInt32? speed (int32 11) (int32 15)) + (int32 3) + (if (betweenInt32? speed (int32 16) (int32 21)) + (int32 4) + (if (betweenInt32? + speed + (int32 22) + (int32 28)) + (int32 5) + (if (>= speed (int32 29)) + (int32 6) + (int32 0)))))))) + (def (turnModeCDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 4)) + (int32 1) + (if (betweenInt32? speed (int32 5) (int32 9)) + (int32 2) + (if (betweenInt32? speed (int32 10) (int32 14)) + (int32 3) + (if (betweenInt32? speed (int32 15) (int32 20)) + (int32 4) + (if (betweenInt32? + speed + (int32 21) + (int32 27)) + (int32 5) + (if (>= speed (int32 28)) + (int32 6) + (int32 0)))))))) + (def (turnModeDDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 4)) + (int32 1) + (if (betweenInt32? speed (int32 5) (int32 8)) + (int32 2) + (if (betweenInt32? speed (int32 9) (int32 12)) + (int32 3) + (if (betweenInt32? speed (int32 13) (int32 17)) + (int32 4) + (if (betweenInt32? + speed + (int32 18) + (int32 24)) + (int32 5) + (if (>= speed (int32 25)) + (int32 6) + (int32 0)))))))) + (def (turnModeEDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 3)) + (int32 1) + (if (betweenInt32? speed (int32 4) (int32 6)) + (int32 2) + (if (betweenInt32? speed (int32 7) (int32 10)) + (int32 3) + (if (betweenInt32? speed (int32 11) (int32 14)) + (int32 4) + (if (betweenInt32? + speed + (int32 15) + (int32 20)) + (int32 5) + (if (betweenInt32? + speed + (int32 21) + (int32 29)) + (int32 6) + (if (>= speed (int32 30)) + (int32 7) + (int32 0))))))))) + (def (turnModeFDistance (speed : Int32)) + : + Int32 + (if (betweenInt32? speed (int32 2) (int32 3)) + (int32 1) + (if (betweenInt32? speed (int32 4) (int32 5)) + (int32 2) + (if (betweenInt32? speed (int32 6) (int32 9)) + (int32 3) + (if (betweenInt32? speed (int32 10) (int32 13)) + (int32 4) + (if (betweenInt32? + speed + (int32 14) + (int32 17)) + (int32 5) + (if (betweenInt32? + speed + (int32 18) + (int32 23)) + (int32 6) + (if (betweenInt32? + speed + (int32 24) + (int32 29)) + (int32 7) + (if (>= speed (int32 30)) + (int32 8) + (int32 0)))))))))) + (def (normalizedHelmFacing (facing : Int32)) + : + Int32 + (mod (+ (mod facing (int32 6)) (int32 6)) (int32 6))))))) + new file mode 100644 --- /dev/null +++ b/templates/original-tactics-parts/ShipUiNames.ss @@ -0,0 +1,153 @@ +(import (jerboa prelude)) + +(def fragment + '((typed-kotlin-file + "com/jerboa/originaltactics/ShipUiNames.kt" + (kotlin-imports (org json JSONObject)) + (typed-library (com jerboa originaltactics) + (export + shipDisplayLabel + shortShipDisplayLabel + shipTechnicalLabel) + (type Int32) (type JSONObject) + (def (shipRawSsdId? (text : String)) + : + Bool + (string-matches-regex? + (string-lowercase text) + "^ssd-[0-9a-f]+-p\\d+-d\\d+$")) + (def (shipUsableLabel? (text : String)) + : + Bool + (and (not (string-blank? text)) + (not (shipRawSsdId? text)))) + (def (shipNullableText + (json : (Nullable JSONObject)) + (key : String)) + : + String + (if (nullable-null? json) + "" + (string-trim + (json-object-opt-string-default + (nullable-get json) + key + "")))) + (def (shipText (json : JSONObject) (key : String)) + : + String + (string-trim + (json-object-opt-string-default json key ""))) + (def (shipFirstUsableLabel (fallback : String) (first : String) (second : String) + (third : String) (fourth : String) (fifth : String)) + : + String + (if (shipUsableLabel? first) + first + (if (shipUsableLabel? second) + second + (if (shipUsableLabel? third) + third + (if (shipUsableLabel? fourth) + fourth + (if (shipUsableLabel? fifth) + fifth + fallback)))))) + (def (shipDisplayLabel + (ship : (Nullable JSONObject)) + (fallback : String (default "-"))) + : + String + (if (nullable-null? ship) + fallback + (let ([json (nullable-get ship)]) + (let ([properties (json-object-opt-json-object + json + "properties")]) + (shipFirstUsableLabel fallback + (shipNullableText properties "display-name") + (shipText json "display-name") + (shipText json "name") + (shipNullableText properties "title-candidate") + (shipNullableText properties "ship-type")))))) + (def (shortShipDisplayLabel + (ship : (Nullable JSONObject)) + (maxChars : Int32 (default (int32 16))) + (fallback : String (default "-"))) + : + String + (let ([label (shipDisplayLabel ship fallback)]) + (if (<= (string-length-int32 label) maxChars) + label + (string-append + (string-trim-end + (string-take label (- maxChars (int32 1)))) + "...")))) + (def (shipTypeSourceBase (module : String) (type : String)) + : + String + (if (string-blank? module) + type + (if (string-blank? type) + module + (string-append module (string-append " " type))))) + (def (shipTruthTechnicalLabel + (ship : (Nullable JSONObject)) + (base : String) + (page : Int32) + (fallback : String)) + : + String + (if (and (not (string-blank? base)) (> page (int32 0))) + (string-append + base + (string-append " p" (int32->string page))) + (if (not (string-blank? base)) + base + (if (> page (int32 0)) + (string-append "SSD p" (int32->string page)) + (shortShipDisplayLabel + ship + (int32 18) + fallback))))) + (def (shipTechnicalLabel + (ship : (Nullable JSONObject)) + (fallback : String (default "-"))) + : + String + (if (nullable-null? ship) + fallback + (let ([json (nullable-get ship)]) + (let ([properties (json-object-opt-json-object + json + "properties")]) + (let ([source (shipNullableText + properties + "source")] + [module (shipNullableText + properties + "source-module")] + [type (shipNullableText + properties + "ship-type")] + [page (if (nullable-null? properties) + (int32 0) + (json-object-opt-int32-default + (nullable-get properties) + "source-page" + (int32 0)))]) + (if (equal? source "ssd-truth") + (shipTruthTechnicalLabel + ship + (shipTypeSourceBase module type) + page + fallback) + (let ([id (shipText json "template-id")]) + (if (and (not (string-blank? id)) + (not (shipRawSsdId? id))) + (string-uppercase id) + (shortShipDisplayLabel + ship + (int32 18) + fallback))))))))))))) + --- a/templates/original-tactics.ss +++ b/templates/original-tactics.ss @@ -1,3585 +1,21 @@ (import (jerboa prelude)) (def fragment - '((include-fragment - "original-tactics-parts/BattleCommandView.kt.ss") - (include-fragment - "original-tactics-parts/BridgeHudView.kt.ss") - (include-fragment - "original-tactics-parts/CombatLogView.kt.ss") - (include-fragment - "original-tactics-parts/CombatTimelineView.kt.ss") - (include-fragment - "original-tactics-parts/CommandAvailabilityView.kt.ss") - (typed-kotlin-file - "com/jerboa/originaltactics/HexMath.kt" - (kotlin-imports (org json JSONArray) (org json JSONObject)) - (typed-library (com jerboa originaltactics) - (export make-ProjectedHelmPose ProjectedHelmPose? - make-ProjectedHelmMove ProjectedHelmMove? - make-ProjectedRangePoint ProjectedRangePoint? - hexRangeFromPositions hexRange currentBattleRange - movementImpulsesForSpeed nextMoveImpulse maneuverMapFromJson - projectedHelmMoves projectedHelmPoseAt - projectedRangeForecast maneuverAbbreviation) - (type Any) (type Int32) (type JSONArray) (type JSONObject) - (record - ProjectedHelmPose - ((q : Int32) (r : Int32) (facing : Int32) (speed : Int32) - (turnMode : String) (distanceSinceTurn : Int32))) - (record - ProjectedHelmMove - ((impulse : Int32) - (maneuver : (Nullable String)) - (pose : ProjectedHelmPose))) - (record - ProjectedRangePoint - ((impulse : Int32) (range : Int32))) - (extern - (asJsonArray (value : Any)) - : - (Nullable JSONArray) - (kotlin-safe-cast JSONArray)) - (extern - (asJsonObject (value : Any)) - : - (Nullable JSONObject) - (kotlin-safe-cast JSONObject)) - (extern - (anyToString (value : Any)) - : - String - (kotlin-member-call toString)) - (extern - (jsonObjectKeys (json : JSONObject)) - : - (Iterator String) - (kotlin-member-call keys)) - (extern - (iteratorHasNext (items : (Iterator String))) - : - Bool - (kotlin-member-call hasNext)) - (extern - (iteratorNext (items : (Iterator String))) - : - String - (kotlin-member-call next)) - (def (int32Abs (value : Int32)) - : - Int32 - (if (< value (int32 0)) (- (int32 0) value) value)) - (def (clampImpulse (value : Int32))